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