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 ;;; You need:
  11 ;;;
  12 ;;;   * guile-1.6.4 (NOT CVS)
  13 ;;;   * Rotty's g-wrap--tng, possibly Janneke's if you have libffi-3.4.
  14 ;;;   * lilypond branch: lilypond_2_3_2b; the framework-* backend
  15 ;;;     loads output-gnome.scm at startup, which seems to break g-wrapped
  16 ;;;     goops.
  17 ;;;
  18 ;;; see also: guile-gtk-general@gnu.org
  19 ;;;
  20 ;;; Try it
  21 ;;;
  22 ;;;   * Install g-wrap, guile-gnome (see script below)
  23 ;;;
  24 ;;;   * Use latin1 encoding for gnome backend, do
  25 ;;;       make -C mf clean
  26 ;;;       make -C mf ENCODING_FILE=$(kpsewhich cork.enc)
  27 ;;;       (cd mf/out && mkfontdir)
  28 ;;;       xset +fp $(pwd)/mf/out
  29 ;;;
  30 ;;;   * Setup PATHs:
  31
  32 "
  33 # do not use guile CVS:
  34 export PATH=/usr/bin/:$PATH
  35 # use g-wrap and guile-gnome from usr/pkg
  36 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile
  37 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib
  38 "
  39
  40 ;;;  * Set XEDITOR and add
  41 ;;;     #(ly:set-point-and-click 'line-column)
  42 ;;;    to your .ly to get point-and-click
  43 ;;;
  44 ;;;  * Run lily: lilypond-bin -fgnome input/simple-song.ly
  45 ;;;
  46 ;;;
  47 ;;;      todo: hmm --output-base broken?
  48 ;;;   ### cd mf && mftrace --encoding=$(kpsewhich cork.enc) --autotrace --output-base=feta-cork-20 feta20.mf && mv feta20.pfa out
  49
  50 ;;; TODO:
  51 ;;;  * pango+feta font (see archives gtk-i18n-list@gnome.org and
  52 ;;;    lilypond-devel)
  53 ;;;    - wait for/help with pango 1.6
  54 ;;;    - convert feta to OpenType (CFF) or TrueType (fontforge?)
  55 ;;;    - hack feta20/feta20.pfa?:
  56 ;;;  * font, canvas, scaling?
  57 ;;;  * implement missing stencil functions
  58 ;;;  * implement missing commands (next, prev? page)
  59 ;;;  * user-interface, keybindings
  60
  61 ;;; Note: this install information is volatile
  62 ;;;       you'll probably want to pull all from
  63 ;;;       from guile-gnome-devel@gnu.org--2004 soon
  64 ;;;
  65
  66 "
  67 #!/bin/bash
  68
  69 set -ex
  70
  71 rm -rf test
  72 mkdir test
  73 cd test
  74
  75 ## 1.  install gnome-devel (Debian/unstable: apt-get install gnome-devel)
  76
  77 ## 2.  *** NOTE: use guile-1.6 for g-wrap and guile-gnome ***
  78 ##### using GUILE CVS g-wrap/guile-gnome is experimental (read: segfaults)
  79 PATH=/usr/bin:$PATH
  80
  81
  82 ## 3.  get g-wrap 2.0
  83 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
  84
  85 rm -rf g-wrap
  86 ## tla get a.rottmann@gmx.at--2004-main/g-wrap--tng g-wrap
  87 ## pull latest g-wrap from janneke -- this step is probably no longer
  88 ## necessary when you read this
  89 tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true
  90 tla get janneke@gnu.org--2004-gnome/g-wrap--janneke g-wrap
  91 cd g-wrap
  92
  93 rm -rf $HOME/usr/pkg/g-wrap
  94 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  95 mkdir =build
  96 cd =build
  97 ../configure --prefix=$HOME/usr/pkg/g-wrap
  98 make install
  99
 100 # cp srfi-34.scm from CVS head ?  --hwn
 101 (cd $HOME/usr/pkg/g-wrap/share/guile/site
 102  mv srfi-34.scm srfi-34.scm-g-wrap
 103  cp $HOME/usr/pkg/guile/share/guile-1.7/srfi/srfi-34.scm .)
 104
 105 cd ../..
 106
 107 ## 4.  get guile-gnome
 108 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
 109 rm -rf guile-gnome
 110 tla get guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
 111 cd guile-gnome
 112 tla build-config -r configs/gnu.org/dev
 113 cd src
 114
 115 ## 5.  get the gnome canvas module
 116 tla get guile-gnome-devel@gnu.org--2004/libgnomecanvas--dev libgnomecanvas
 117
 118 ## pull latest defs from janneke -- this step is probably no longer
 119 ## necessary when you read this
 120 ## tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true
 121 ## rm -rf defs
 122 ## tla get janneke@gnu.org--2004-gnome/defs--janneke defs
 123
 124 rm -rf $HOME/usr/pkg/guile-gnome
 125 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
 126 mkdir ../=build
 127 cd ../=build
 128
 129 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
 130 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
 131 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
 132
 133 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
 134
 135 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
 136
 137 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
 138 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
 139 guile -s ../src/libgnomecanvas/examples/canvas.scm
 140
 141
 142 # simple test
 143 guile -s ../src/libgnomecanvas/examples/canvas.scm
 144
 145 "
 146
 147 (debug-enable 'backtrace)
 148
 149 (define-module (scm output-gnome)
 150   #:export (header))
 151
 152 (define this-module (current-module))
 153
 154 (use-modules
 155  (guile)
 156  (ice-9 regex)
 157  (srfi srfi-13)
 158  (lily)
 159  (gnome gtk)
 160  (gnome gtk gdk-event)
 161  ;; the name of the module will change to canvas rsn
 162  (gnome gw libgnomecanvas))
 163  ;;(gnome gw canvas))
 164
 165
 166 ;;; Lily output interface --- fix silly names and docme
 167
 168 "
 169  The output interface has functions for
 170   * formatting stencils, and
 171   * output commands
 172
 173  Stencils:
 174  beam
 175  bezier-sandwich
 176  bracket
 177  ...
 178
 179  Commands:
 180  define-fonts
 181  header
 182  placebox
 183  ...
 184
 185
 186  The Bare minimum interface for \score { \notes c } } should
 187  implement:
 188
 189     INTERFACE-output-expression
 190     char
 191     filledbox
 192     placebox
 193
 194  and should intercept:
 195 "
 196
 197 (define (dummy . foo) #f)
 198
 199 ;; minimal intercept list:
 200 (define output-interface-intercept
 201   '(comment
 202     define-fonts
 203     end-output
 204     header
 205     header-end
 206     lily-def
 207     no-origin
 208     output-scopes
 209     start-page
 210     stop-page
 211     start-system
 212     stop-system))
 213
 214 (map (lambda (x) (module-define! this-module x dummy))
 215      output-interface-intercept)
 216
 217 (define-public (gnome-output-expression expr port)
 218   (display (dispatch expr) port))
 219
 220 (define (dispatch expr)
 221   (if (pair? expr)
 222       (let ((keyword (car expr)))
 223         (cond
 224          ((eq? keyword 'some-func) "")
 225          ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
 226          (else
 227           (if (module-defined? this-module keyword)
 228               (apply (eval keyword this-module) (cdr expr))
 229               (begin
 230                 (display
 231                  (string-append "undefined: " (symbol->string keyword) "\n"))
 232                 "")))))
 233       expr))
 234
 235 ;;; Global vars
 236 (define main-window #f)
 237 (define main-canvas #f)
 238 (define canvas-root #f)
 239
 240 (define system-origin '(0 . 0))
 241
 242 ;; UGHr
 243 (define item-locations (make-hash-table 31))
 244 (define location #f)
 245
 246 (define canvas-width 400)
 247 (define canvas-height
 248   (inexact->exact (round (* 1.42 canvas-width))))
 249
 250 (define font-paper #f)
 251
 252 ;;(define pixels-per-unit 1.0)
 253 (define pixels-per-unit 2.0)
 254
 255 ;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions?
 256 ;;(define output-scale (* 2 2.83464566929134))
 257 ;;(define output-scale 2.83464566929134)
 258 (define OUTPUT-SCALE 2.83464566929134)
 259 (define output-scale (* OUTPUT-SCALE pixels-per-unit))
 260 ;;(define output-scale 1)
 261
 262 ;; helper functions
 263 (define (stderr string . rest)
 264   (apply format (cons (current-error-port) (cons string rest)))
 265   (force-output (current-error-port)))
 266
 267 (define (utf8 i)
 268   (cond
 269    ((< i #x80) (make-string 1 (integer->char i)))
 270    ((< i #x800) (list->string
 271                  (map integer->char
 272                       (list (+ #xc0 (quotient i #x40))
 273                             (+ #x80 (modulo i #x40))))))
 274    ((< i #x10000)
 275     (let ((x (quotient i #x1000))
 276           (y (modulo i #x1000)))
 277       (list->string
 278        (map integer->char
 279             (list (+ #xe0 x)
 280                   (+ #x80 (quotient y #x40))
 281                   (+ #x80 (modulo y #x40)))))))
 282    (else FIXME)))
 283
 284 (define (custom-utf8 i)
 285   (if (< i 80)
 286       (utf8 i)
 287       (utf8 (+ #xee00 i))))
 288
 289 (define x-editor #f)
 290 (define (get-x-editor)
 291   (if (not x-editor)
 292       (set! x-editor (getenv "XEDITOR")))
 293   x-editor)
 294
 295 (define ifs #f)
 296 (define (get-ifs)
 297   (if (not ifs)
 298       (set! ifs (getenv "IFS")))
 299   (if (not ifs)
 300       (set! ifs "       "))
 301   ifs)
 302
 303 (define (spawn-editor location)
 304   (let* ((line (car location))
 305          (column (cadr location))
 306          (file-name (caddr location))
 307          (template (substring (get-x-editor) 0))
 308
 309          ;; Adhere to %l %c %f?
 310          (command
 311           (regexp-substitute/global
 312            #f "%l" (regexp-substitute/global
 313                     #f "%c"
 314                     (regexp-substitute/global
 315                      #f "%f" template 'pre file-name 'post)
 316                     'pre (number->string column)
 317                     'post)
 318            'pre (number->string line) 'post)))
 319
 320     (stderr "spawning: ~s\n" command)
 321     (if (= (primitive-fork) 0)
 322         (let ((command-list (string-split command #\ )));; (get-ifs))))
 323           (apply execlp command-list)
 324           (primitive-exit)))))
 325
 326 (define location-callback spawn-editor)
 327
 328 (define (item-event item event . data)
 329   (case (gdk-event:type event)
 330     ((enter-notify) (gobject-set-property item 'fill-color "white"))
 331     ((leave-notify) (gobject-set-property item 'fill-color "black"))
 332     ((button-press)
 333      (let ((location (hashq-ref item-locations item #f)))
 334        (if location
 335            (location-callback location)
 336            (stderr "no location\n"))))
 337     ((2button-press) (gobject-set-property item 'fill-color "red")))
 338   #t)
 339
 340 ;; TODO: one list per-page
 341 (define text-items '())
 342 (define (scale-canvas factor)
 343   (set! pixels-per-unit (* pixels-per-unit factor))
 344   (set-pixels-per-unit main-canvas pixels-per-unit)
 345   (for-each
 346    (lambda (x)
 347      (let ((scale (gobject-get-property x 'scale))
 348            (points (gobject-get-property x 'size-points)))
 349        ;;(stderr "scaling item:~S to ~S\n" x scale)
 350        ;; (stderr "scaling item:~S to ~S\n" x points)
 351        (gobject-set-property x 'size-points (* points factor))))
 352        ;;(gobject-set-property x 'scale pixels-per-unit)
 353        ;;(gobject-set-property x 'scale-set #t))
 354      text-items))
 355
 356 (define (key-press-event item event . data)
 357   (let ((keyval (gdk-event-key:keyval event))
 358         (mods (gdk-event-key:modifiers event)))
 359     (cond ((and (or (eq? keyval gdk:q)
 360                     (eq? keyval gdk:w))
 361                 (equal? mods '(control-mask modifier-mask)))
 362            (gtk-main-quit))
 363           ((and #t ;;(null? mods)
 364                 (eq? keyval gdk:plus))
 365            (scale-canvas 2))
 366           ((and #t ;; (null? mods)
 367                 (eq? keyval gdk:minus))
 368            (scale-canvas 0.5)))
 369     #f))
 370
 371 (define (char font i)
 372   (text font (utf8 i)))
 373
 374 (define (placebox x y expr)
 375   (stderr "item: ~S\n" expr)
 376   (let ((item expr))
 377     ;;(if item
 378     ;; FIXME ugly hack to skip #unspecified ...
 379     (if (and item (not (eq? item (if #f #f))))
 380         (begin
 381           (move item
 382                 (* output-scale (+ (car system-origin) x))
 383                 (* output-scale (- (car system-origin) y)))
 384           (affine-relative item output-scale 0 0 output-scale 0 0)
 385
 386           (gtype-instance-signal-connect item 'event item-event)
 387           (if location
 388               (hashq-set! item-locations item location))
 389           item)
 390         #f)))
 391
 392 (define (round-filled-box breapth width depth height blot-diameter)
 393   ;; FIXME: no rounded corners on rectangle
 394   (make <gnome-canvas-rect>
 395     #:parent canvas-root
 396     #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
 397     #:fill-color "black" #:width-units blot-diameter))
 398
 399 (define (fontify font expr)
 400   #f)
 401
 402 (define (end-output)
 403   (gtk-main))
 404
 405 (define (header . rest)
 406   (let* ((window (make <gtk-window> #:type 'toplevel))
 407          (button (make <gtk-button> #:label "Exit"))
 408          (canvas (make <gnome-canvas>))
 409          (vbox (make <gtk-vbox> #:homogeneous #f))
 410          (scrolled (make <gtk-scrolled-window>)))
 411
 412     (add window vbox)
 413     (add vbox scrolled)
 414     (add scrolled canvas)
 415
 416     (set-size-request button canvas-width 20)
 417     (add vbox button)
 418     (set-child-packing vbox button #f #f 0 'end)
 419
 420     (gtype-instance-signal-connect button 'clicked
 421                                    (lambda (b) (gtk-main-quit)))
 422
 423     ;; papersize
 424     (set-size-request canvas canvas-width canvas-height)
 425     (set-scroll-region canvas 0 0 2000 4000)
 426
 427     (gtype-instance-signal-connect window 'key-press-event key-press-event)
 428
 429     (set-pixels-per-unit canvas pixels-per-unit)
 430     (show-all window)
 431     (set! canvas-root (root canvas))
 432     (set! main-canvas canvas)
 433     (set! main-window window)))
 434
 435 (define (pango-font-name font)
 436   (cond
 437    ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
 438     "lilypond-feta, regular 32")
 439    (else
 440     (ly:font-filename font))))
 441
 442 (define (pango-font-size font)
 443   (let* ((designsize (ly:font-design-size font))
 444          (magnification (* (ly:font-magnification font)))
 445          ;;(ops (ly:paper-lookup paper 'outputscale))
 446          ;;(ops (* pixels-per-unit OUTPUT-SCALE))
 447          ;;(ops (* pixels-per-unit pixels-per-unit))
 448          (ops (* (/ 12 20) (* pixels-per-unit pixels-per-unit)))
 449          (scaling (* ops magnification designsize)))
 450     scaling))
 451
 452 (define (text font string)
 453   (stderr "font-name: ~S\n" (ly:font-name font))
 454   ;; TODO s/filename/file-name/
 455   (stderr "font-filename: ~S\n" (ly:font-filename font))
 456
 457   (stderr "pango-font-name: ~S\n" (pango-font-name font))
 458   (stderr "pango-font-size: ~S\n" (pango-font-size font))
 459   (set!
 460    text-items
 461    (cons
 462     (make <gnome-canvas-text>
 463       #:parent canvas-root
 464       #:x 0 #:y 0
 465       ;;    #:font "new century schoolbook, i bold 20"
 466       #:font (pango-font-name font)
 467       ;; #:size-points 12
 468       #:size-points (pango-font-size font)
 469       ;;#:size (pango-font-size font)
 470       #:size-set #t
 471
 472       ;;apparently no effect :-(
 473       ;;#:scale 1.0
 474       ;;#:scale-set #t
 475
 476       #:fill-color "black"
 477       #:text string
 478       #:anchor 'west)
 479     text-items))
 480   (car text-items))
 481
 482 (define (filledbox a b c d)
 483   (round-filled-box a b c d 0.001))
 484
 485 ;; WTF is this in every backend?
 486 (define (horizontal-line x1 x2 thickness)
 487   ;;(let ((thickness 2))
 488   (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
 489
 490 (define (start-system origin . rest)
 491   (set! system-origin origin))
 492
 493 ;; origin -- bad name
 494 (define (define-origin file line col)
 495   ;; ughr, why is this not passed as [part of] stencil object
 496   (set! location (if (procedure? point-and-click)
 497                      ;; duh, only silly string append
 498                      ;; (point-and-click line col file)
 499                      (list line col file)
 500                      #f)))
 501