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