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