scm/output-gnome.scm

   1 ;;;; output-gnome.scm -- implement GNOME canvas output
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6
   7
   8 ;;; HIP -- hack in progress
   9 ;;;
  10 ;;; status: hello-world
  11 ;;;
  12 ;;; This first working version needs rotty's g-wrap--tng.
  13 ;;; (janneke's guile-gnome patches now in main archive).
  14 ;;;
  15 ;;; Try it:
  16 ;;;     lilypond-bin -fgnome input/simple-song.ly
  17
  18 ;;; Set XEDITOR and add
  19 ;;;    #(ly:set-point-and-click 'line-column)
  20 ;;; to your .ly to get point-and-click
  21
  22 ;;; TODO:
  23 ;;;  * pango+feta font (see archives gtk-i18n-list@gnome.org and
  24 ;;;    lilypond-devel)
  25 ;;;    - wait for/help with pango 1.6
  26 ;;;    - convert feta to OpenType (CFF) or TrueType (fontforge?)
  27 ;;;    - hack feta20: use latin1 encoding for gnome backend
  28 ;;;  * implement missing stencil functions
  29 ;;;  * implement missing commands (next, prev? page)
  30 ;;;  * user-interface, keybindings
  31
  32 ;;; Note: this install information is volatile
  33 ;;;       you'll probably want to pull all from
  34 ;;;       from guile-gnome-devel@gnu.org--2004 soon
  35 ;;;
  36 ;;; move this into workbook?
  37
  38 "
  39 ## install gnome-devel
  40
  41 ## use guile-1.6 for g-wrap/guile-gnome
  42 PATH=/usr/bin:$PATH
  43
  44 ## get g-wrap 2.0
  45 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
  46
  47 rm -rf gw-pristine
  48 tla get a.rottmann@gmx.at--2004-main/g-wrap--tng gw-pristine
  49 cd gw-pristine
  50
  51 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  52 mkdir =build
  53 cd =build
  54 ../configure --prefix=$HOME/usr/pkg/g-wrap
  55 make install
  56
  57 cd ../..
  58
  59 ## get guile-gnome
  60 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
  61 rm -rf guile-gnome
  62 tla guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
  63 cd guile-gnome
  64 tla build-config -r configs/gnu.org/dev
  65 cd src
  66
  67 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  68 mkdir ../=build
  69 cd ../=build
  70
  71 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
  72 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
  73 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
  74
  75 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
  76
  77 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
  78 #FIXME: fixup
  79 (cd $HOME/usr/pkg/guile-gnome/share/guile/gnome && mv gtk/g[dt]k.scm gw)
  80
  81 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
  82 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
  83 guile -s ../src/gtk/examples/hello.scm
  84
  85
  86 "
  87
  88
  89
  90 (debug-enable 'backtrace)
  91
  92 (define-module (scm output-gnome))
  93 (define this-module (current-module))
  94
  95 (use-modules
  96  (guile)
  97  (ice-9 regex)
  98  (srfi srfi-13)
  99  (lily)
 100  (gnome gtk)
 101  (gnome gtk gdk-event)
 102  (gnome gw libgnomecanvas))
 103
 104
 105 ;;; Lily output interface --- fix silly names and docme
 106
 107 "
 108  The output interface has functions for
 109   * formatting stencils, and
 110   * output commands
 111
 112  Stencils:
 113  beam
 114  bezier-sandwich
 115  bracket
 116  ...
 117
 118  Commands:
 119  define-fonts
 120  header
 121  placebox
 122  ...
 123
 124
 125  The Bare minimum interface for \score { \notes c } } should
 126  implement:
 127
 128     INTERFACE-output-expression
 129     char
 130     filledbox
 131     placebox
 132
 133  and should intercept:
 134 "
 135
 136 (define (dummy . foo) #f)
 137
 138 ;; minimal intercept list:
 139 (define output-interface-intercept
 140   '(
 141     comment
 142     define-fonts
 143     end-output
 144     header
 145     header-end
 146     lily-def
 147     no-origin
 148     output-scopes
 149     start-page
 150     stop-page
 151     start-system
 152     stop-system
 153  ))
 154
 155 (map (lambda (x) (module-define! this-module x dummy))
 156      output-interface-intercept)
 157
 158 (define-public (gnome-output-expression expr port)
 159   (display (dispatch expr) port))
 160
 161 (define (dispatch expr)
 162   (if (pair? expr)
 163       (let ((keyword (car expr)))
 164         (cond
 165          ((eq? keyword 'some-func) "")
 166          ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
 167          (else
 168           (if (module-defined? this-module keyword)
 169               (apply (eval keyword this-module) (cdr expr))
 170               (begin
 171                 (display
 172                  (string-append "undefined: " (symbol->string keyword) "\n"))
 173                 "")))))
 174       expr))
 175
 176 ;;; Global vars
 177 (define main-window #f)
 178 (define main-canvas #f)
 179 (define canvas-root #f)
 180
 181 (define system-origin '(0 . 0))
 182
 183 ;; UGHr
 184 (define item-locations (make-hash-table 31))
 185 (define location #f)
 186
 187 (define canvas-width 400)
 188 (define canvas-height
 189   (inexact->exact (round (* 1.42 canvas-width))))
 190
 191 ;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions?
 192 (define output-scale (* 2 2.83464566929134))
 193 ;;(define output-scale 2.83464566929134)
 194 ;;(define output-scale 1)
 195
 196 ;; helper functions
 197 (define (stderr string . rest)
 198   (apply format (cons (current-error-port) (cons string rest)))
 199   (force-output (current-error-port)))
 200
 201
 202 (define x-editor #f)
 203 (define (get-x-editor)
 204   (if (not x-editor)
 205       (set! x-editor (getenv "XEDITOR")))
 206   x-editor)
 207
 208 (define ifs #f)
 209 (define (get-ifs)
 210   (if (not ifs)
 211       (set! ifs (getenv "IFS")))
 212   (if (not ifs)
 213       (set! ifs "       "))
 214   ifs)
 215
 216 (define (spawn-editor location)
 217   (let* ((line (car location))
 218          (column (cadr location))
 219          (file-name (caddr location))
 220          (template (substring (get-x-editor) 0))
 221
 222          ;; Adhere to %l %c %f?
 223          (command
 224           (regexp-substitute/global
 225            #f "%l" (regexp-substitute/global
 226                     #f "%c"
 227                     (regexp-substitute/global
 228                      #f "%f" template 'pre file-name 'post)
 229                     'pre (number->string column)
 230                     'post)
 231            'pre (number->string line) 'post)))
 232
 233     (stderr "spawning: ~s\n" command)
 234     (if (= (primitive-fork) 0)
 235         (let ((command-list (string-split command #\ )));; (get-ifs))))
 236           (apply execlp command-list)
 237           (primitive-exit)))))
 238
 239 (define location-callback spawn-editor)
 240
 241 (define (item-event item event . data)
 242   (case (gdk-event:type event)
 243     ((enter-notify) (gobject-set-property item 'fill-color "white"))
 244     ((leave-notify) (gobject-set-property item 'fill-color "black"))
 245     ((button-press)
 246      (let ((location (hashq-ref item-locations item #f)))
 247        (if location
 248            (location-callback location)
 249            (stderr "no location\n"))))
 250     ((2button-press) (gobject-set-property item 'fill-color "red")))
 251   #t)
 252
 253 (define pixels-per-unit 1.0)
 254 (define (key-press-event item event . data)
 255   (let ((keyval (gdk-event-key:keyval event))
 256         (mods (gdk-event-key:modifiers event)))
 257     (cond ((and (or (eq? keyval gdk:q)
 258                     (eq? keyval gdk:w))
 259                 (equal? mods '(control-mask modifier-mask)))
 260            (gtk-main-quit))
 261           ((and #t ;;(null? mods)
 262                 (eq? keyval gdk:plus))
 263            (set! pixels-per-unit (* pixels-per-unit 2))
 264            (set-pixels-per-unit main-canvas pixels-per-unit))
 265           ((and #t ;; (null? mods)
 266                 (eq? keyval gdk:minus))
 267            (set! pixels-per-unit (/ pixels-per-unit 2))
 268            (set-pixels-per-unit main-canvas pixels-per-unit)))
 269     #f))
 270
 271 (define (char font i)
 272   ;;(text font (make-string 1 (integer->char i))))
 273   (text font "a"))
 274
 275 (define (placebox x y expr)
 276   (let ((item expr))
 277     (if item
 278         (begin
 279           (move item
 280                 (* output-scale (+ (car system-origin) x))
 281                 (* output-scale (- (car system-origin) y)))
 282           (affine-relative item output-scale 0 0 output-scale 0 0)
 283
 284           (gtype-instance-signal-connect item 'event item-event)
 285           (if location
 286               (hashq-set! item-locations item location))
 287           item)
 288         #f)))
 289
 290 (define (round-filled-box breapth width depth height blot-diameter)
 291   ;; FIXME: no rounded corners on rectangle
 292   (make <gnome-canvas-rect>
 293     #:parent canvas-root
 294     #:x1 (- breapth) #:y1 (- depth) #:x2 width #:y2 height
 295     #:fill-color "black" #:width-units blot-diameter))
 296
 297 (define (fontify font expr)
 298   #f)
 299
 300 (define (end-output)
 301   (gtk-main))
 302
 303 (define (header . rest)
 304   (let* ((window (make <gtk-window> #:type 'toplevel))
 305          (button (make <gtk-button> #:label "Exit"))
 306          (canvas (make <gnome-canvas>))
 307          (vbox (make <gtk-vbox> #:homogeneous #f))
 308          (scrolled (make <gtk-scrolled-window>)))
 309
 310     (add window vbox)
 311     (add vbox scrolled)
 312     (add scrolled canvas)
 313
 314     (set-size-request button canvas-width 20)
 315     (add vbox button)
 316     (set-child-packing vbox button #f #f 0 'end)
 317
 318     (gtype-instance-signal-connect button 'clicked
 319                                    (lambda (b) (gtk-main-quit)))
 320
 321     ;; papersize
 322     (set-size-request canvas canvas-width canvas-height)
 323     (set-scroll-region canvas 0 0 2000 4000)
 324
 325     (gtype-instance-signal-connect window 'key-press-event key-press-event)
 326
 327     (show-all window)
 328     (set! canvas-root (root canvas))
 329     (set! main-canvas canvas)
 330     (set! main-window window)))
 331
 332 (define (text font string)
 333   (make <gnome-canvas-text>
 334     #:parent canvas-root
 335     #:x 0 #:y 0
 336     #:size-points 12
 337     #:size-set #t
 338     #:font "new century schoolbook, i bold 20"
 339     #:fill-color "black"
 340     #:text string))
 341
 342 (define (filledbox a b c d)
 343   (round-filled-box a b c d 0.001))
 344
 345 ;; WTF is this in every backend?
 346 (define (horizontal-line x1 x2 thickness)
 347   ;;(let ((thickness 2))
 348   (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
 349
 350 (define (start-system origin . rest)
 351   (set! system-origin origin))
 352
 353 ;; origin -- bad name
 354 (define (define-origin file line col)
 355   ;; ughr, why is this not passed as [part of] stencil object
 356   (set! location (if (procedure? point-and-click)
 357                      ;; duh, only silly string append
 358                      ;; (point-and-click line col file)
 359                      (list line col file)
 360                      #f)))
 361