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