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  (gnome gw libgnomecanvas))
 162
 163
 164 ;;; Lily output interface --- fix silly names and docme
 165
 166 "
 167  The output interface has functions for
 168   * formatting stencils, and
 169   * output commands
 170
 171  Stencils:
 172  beam
 173  bezier-sandwich
 174  bracket
 175  ...
 176
 177  Commands:
 178  define-fonts
 179  header
 180  placebox
 181  ...
 182
 183
 184  The Bare minimum interface for \score { \notes c } } should
 185  implement:
 186
 187     INTERFACE-output-expression
 188     char
 189     filledbox
 190     placebox
 191
 192  and should intercept:
 193 "
 194
 195 (define (dummy . foo) #f)
 196
 197 ;; minimal intercept list:
 198 (define output-interface-intercept
 199   '(comment
 200     define-fonts
 201     end-output
 202     header
 203     header-end
 204     lily-def
 205     no-origin
 206     output-scopes
 207     start-page
 208     stop-page
 209     start-system
 210     stop-system))
 211
 212 (map (lambda (x) (module-define! this-module x dummy))
 213      output-interface-intercept)
 214
 215 (define-public (gnome-output-expression expr port)
 216   (display (dispatch expr) port))
 217
 218 (define (dispatch expr)
 219   (if (pair? expr)
 220       (let ((keyword (car expr)))
 221         (cond
 222          ((eq? keyword 'some-func) "")
 223          ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
 224          (else
 225           (if (module-defined? this-module keyword)
 226               (apply (eval keyword this-module) (cdr expr))
 227               (begin
 228                 (display
 229                  (string-append "undefined: " (symbol->string keyword) "\n"))
 230                 "")))))
 231       expr))
 232
 233 ;;; Global vars
 234 (define main-window #f)
 235 (define main-canvas #f)
 236 (define canvas-root #f)
 237
 238 (define system-origin '(0 . 0))
 239
 240 ;; UGHr
 241 (define item-locations (make-hash-table 31))
 242 (define location #f)
 243
 244 (define canvas-width 400)
 245 (define canvas-height
 246   (inexact->exact (round (* 1.42 canvas-width))))
 247
 248 (define font-paper #f)
 249
 250 ;;(define pixels-per-unit 1.0)
 251 (define pixels-per-unit 2.0)
 252
 253 ;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions?
 254 ;;(define output-scale (* 2 2.83464566929134))
 255 ;;(define output-scale 2.83464566929134)
 256 (define OUTPUT-SCALE 2.83464566929134)
 257 (define output-scale (* OUTPUT-SCALE pixels-per-unit))
 258 ;;(define output-scale 1)
 259
 260 ;; helper functions
 261 (define (stderr string . rest)
 262   (apply format (cons (current-error-port) (cons string rest)))
 263   (force-output (current-error-port)))
 264
 265 (define (utf8 i)
 266   (cond
 267    ((< i #x80) (make-string 1 (integer->char i)))
 268    ((< i #x800) (list->string
 269                  (map integer->char
 270                       (list (+ #xc0 (quotient i #x40))
 271                             (+ #x80 (modulo i #x40))))))
 272    ((< i #x10000)
 273     (let ((x (quotient i #x1000))
 274           (y (modulo i #x1000)))
 275       (list->string
 276        (map integer->char
 277             (list (+ #xe0 x)
 278                   (+ #x80 (quotient y #x40))
 279                   (+ #x80 (modulo y #x40)))))))
 280    (else FIXME)))
 281
 282 (define (custom-utf8 i)
 283   (if (< i 80)
 284       (utf8 i)
 285       (utf8 (+ #xee00 i))))
 286
 287 (define x-editor #f)
 288 (define (get-x-editor)
 289   (if (not x-editor)
 290       (set! x-editor (getenv "XEDITOR")))
 291   x-editor)
 292
 293 (define ifs #f)
 294 (define (get-ifs)
 295   (if (not ifs)
 296       (set! ifs (getenv "IFS")))
 297   (if (not ifs)
 298       (set! ifs "       "))
 299   ifs)
 300
 301 (define (spawn-editor location)
 302   (let* ((line (car location))
 303          (column (cadr location))
 304          (file-name (caddr location))
 305          (template (substring (get-x-editor) 0))
 306
 307          ;; Adhere to %l %c %f?
 308          (command
 309           (regexp-substitute/global
 310            #f "%l" (regexp-substitute/global
 311                     #f "%c"
 312                     (regexp-substitute/global
 313                      #f "%f" template 'pre file-name 'post)
 314                     'pre (number->string column)
 315                     'post)
 316            'pre (number->string line) 'post)))
 317
 318     (stderr "spawning: ~s\n" command)
 319     (if (= (primitive-fork) 0)
 320         (let ((command-list (string-split command #\ )));; (get-ifs))))
 321           (apply execlp command-list)
 322           (primitive-exit)))))
 323
 324 (define location-callback spawn-editor)
 325
 326 (define (item-event item event . data)
 327   (case (gdk-event:type event)
 328     ((enter-notify) (gobject-set-property item 'fill-color "white"))
 329     ((leave-notify) (gobject-set-property item 'fill-color "black"))
 330     ((button-press)
 331      (let ((location (hashq-ref item-locations item #f)))
 332        (if location
 333            (location-callback location)
 334            (stderr "no location\n"))))
 335     ((2button-press) (gobject-set-property item 'fill-color "red")))
 336   #t)
 337
 338 ;; TODO: one list per-page
 339 (define text-items '())
 340 (define (scale-canvas factor)
 341   (set! pixels-per-unit (* pixels-per-unit factor))
 342   (set-pixels-per-unit main-canvas pixels-per-unit)
 343   (for-each
 344    (lambda (x)
 345      (let ((scale (gobject-get-property x 'scale))
 346            (points (gobject-get-property x 'size-points)))
 347        ;;(stderr "scaling item:~S to ~S\n" x scale)
 348        ;; (stderr "scaling item:~S to ~S\n" x points)
 349        (gobject-set-property x 'size-points (* points factor))))
 350        ;;(gobject-set-property x 'scale pixels-per-unit)
 351        ;;(gobject-set-property x 'scale-set #t))
 352      text-items))
 353
 354 (define (key-press-event item event . data)
 355   (let ((keyval (gdk-event-key:keyval event))
 356         (mods (gdk-event-key:modifiers event)))
 357     (cond ((and (or (eq? keyval gdk:q)
 358                     (eq? keyval gdk:w))
 359                 (equal? mods '(control-mask modifier-mask)))
 360            (gtk-main-quit))
 361           ((and #t ;;(null? mods)
 362                 (eq? keyval gdk:plus))
 363            (scale-canvas 2))
 364           ((and #t ;; (null? mods)
 365                 (eq? keyval gdk:minus))
 366            (scale-canvas 0.5)))
 367     #f))
 368
 369 (define (char font i)
 370   (text font (utf8 i)))
 371
 372 (define (placebox x y expr)
 373   (stderr "item: ~S\n" expr)
 374   (let ((item expr))
 375     ;;(if item
 376     ;; FIXME ugly hack to skip #unspecified ...
 377     (if (and item (not (eq? item (if #f #f))))
 378         (begin
 379           (move item
 380                 (* output-scale (+ (car system-origin) x))
 381                 (* output-scale (- (car system-origin) y)))
 382           (affine-relative item output-scale 0 0 output-scale 0 0)
 383
 384           (gtype-instance-signal-connect item 'event item-event)
 385           (if location
 386               (hashq-set! item-locations item location))
 387           item)
 388         #f)))
 389
 390 (define (round-filled-box breapth width depth height blot-diameter)
 391   ;; FIXME: no rounded corners on rectangle
 392   (make <gnome-canvas-rect>
 393     #:parent canvas-root
 394     #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
 395     #:fill-color "black" #:width-units blot-diameter))
 396
 397 (define (fontify font expr)
 398   #f)
 399
 400 (define (end-output)
 401   (gtk-main))
 402
 403 (define (header . rest)
 404   (let* ((window (make <gtk-window> #:type 'toplevel))
 405          (button (make <gtk-button> #:label "Exit"))
 406          (canvas (make <gnome-canvas>))
 407          (vbox (make <gtk-vbox> #:homogeneous #f))
 408          (scrolled (make <gtk-scrolled-window>)))
 409
 410     (add window vbox)
 411     (add vbox scrolled)
 412     (add scrolled canvas)
 413
 414     (set-size-request button canvas-width 20)
 415     (add vbox button)
 416     (set-child-packing vbox button #f #f 0 'end)
 417
 418     (gtype-instance-signal-connect button 'clicked
 419                                    (lambda (b) (gtk-main-quit)))
 420
 421     ;; papersize
 422     (set-size-request canvas canvas-width canvas-height)
 423     (set-scroll-region canvas 0 0 2000 4000)
 424
 425     (gtype-instance-signal-connect window 'key-press-event key-press-event)
 426
 427     (set-pixels-per-unit canvas pixels-per-unit)
 428     (show-all window)
 429     (set! canvas-root (root canvas))
 430     (set! main-canvas canvas)
 431     (set! main-window window)))
 432
 433 (define (pango-font-name font)
 434   (cond
 435    ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
 436     "lilypond-feta, regular 32")
 437    (else
 438     (ly:font-filename font))))
 439
 440 (define (pango-font-size font)
 441   (let* ((designsize (ly:font-design-size font))
 442          (magnification (* (ly:font-magnification font)))
 443          ;;(ops (ly:paper-lookup paper 'outputscale))
 444          ;;(ops (* pixels-per-unit OUTPUT-SCALE))
 445          ;;(ops (* pixels-per-unit pixels-per-unit))
 446          (ops (* (/ 12 20) (* pixels-per-unit pixels-per-unit)))
 447          (scaling (* ops magnification designsize)))
 448     scaling))
 449
 450 (define (text font string)
 451   (stderr "font-name: ~S\n" (ly:font-name font))
 452   ;; TODO s/filename/file-name/
 453   (stderr "font-filename: ~S\n" (ly:font-filename font))
 454
 455   (stderr "pango-font-name: ~S\n" (pango-font-name font))
 456   (stderr "pango-font-size: ~S\n" (pango-font-size font))
 457   (set!
 458    text-items
 459    (cons
 460     (make <gnome-canvas-text>
 461       #:parent canvas-root
 462       #:x 0 #:y 0
 463       ;;    #:font "new century schoolbook, i bold 20"
 464       #:font (pango-font-name font)
 465       ;; #:size-points 12
 466       #:size-points (pango-font-size font)
 467       ;;#:size (pango-font-size font)
 468       #:size-set #t
 469
 470       ;;apparently no effect :-(
 471       ;;#:scale 1.0
 472       ;;#:scale-set #t
 473
 474       #:fill-color "black"
 475       #:text string
 476       #:anchor 'west)
 477     text-items))
 478   (car text-items))
 479
 480 (define (filledbox a b c d)
 481   (round-filled-box a b c d 0.001))
 482
 483 ;; WTF is this in every backend?
 484 (define (horizontal-line x1 x2 thickness)
 485   ;;(let ((thickness 2))
 486   (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
 487
 488 (define (start-system origin . rest)
 489   (set! system-origin origin))
 490
 491 ;; origin -- bad name
 492 (define (define-origin file line col)
 493   ;; ughr, why is this not passed as [part of] stencil object
 494   (set! location (if (procedure? point-and-click)
 495                      ;; duh, only silly string append
 496                      ;; (point-and-click line col file)
 497                      (list line col file)
 498                      #f)))
 499