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