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 ;;; status: hello-world
  11 ;;;
  12 ;;; This first working version needs rotty's g-wrap--tng.
  13 ;;; (janneke's guile-gnome patches now in main archive).
  14 ;;;
  15 ;;; Try it:
  16 ;;;     lilypond-bin -fgnome input/simple-song.ly
  17 ;;;
  18
  19 ;;; TODO:
  20 ;;;  * pango+feta font (see archives gtk-i18n-list@gnome.org and
  21 ;;;    lilypond-devel)
  22 ;;;    - wait for/help with pango 1.6
  23 ;;;    - convert feta to OpenType (CFF) or TrueType (fontforge?)
  24 ;;;    - hack feta20: use latin1 encoding for gnome backend
  25 ;;;  * implement missing stencil functions
  26 ;;;  * implement missing commands (next, prev? page)
  27
  28 ;;; Note: this install information is volatile
  29 ;;;       you'll probably want to pull all from
  30 ;;;       from guile-gnome-devel@gnu.org--2004 soon
  31 ;;;
  32 ;;; move this into workbook?
  33
  34 "
  35 ## install gnome-devel
  36
  37 ## use guile-1.6 for g-wrap/guile-gnome
  38 PATH=/usr/bin:$PATH
  39
  40 ## get g-wrap 2.0
  41 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
  42
  43 rm -rf gw-pristine
  44 tla get a.rottmann@gmx.at--2004-main/g-wrap--tng gw-pristine
  45 cd gw-pristine
  46
  47 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  48 mkdir =build
  49 cd =build
  50 ../configure --prefix=$HOME/usr/pkg/g-wrap
  51 make install
  52
  53 cd ../..
  54
  55 ## get guile-gnome
  56 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
  57 rm -rf guile-gnome
  58 tla guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
  59 cd guile-gnome
  60 tla build-config -r configs/gnu.org/dev
  61 cd src
  62
  63 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  64 mkdir ../=build
  65 cd ../=build
  66
  67 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
  68 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
  69 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
  70
  71 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
  72
  73 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
  74 #FIXME: fixup
  75 (cd $HOME/usr/pkg/guile-gnome/share/guile/gnome && mv gtk/g[dt]k.scm gw)
  76
  77 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
  78 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
  79 guile -s ../src/gtk/examples/hello.scm
  80
  81
  82 lilypond-bin -fgnome input/simple-song.ly
  83
  84
  85 "
  86
  87
  88
  89 (debug-enable 'backtrace)
  90
  91 (define-module (scm output-gnome))
  92 (define this-module (current-module))
  93
  94 (use-modules
  95  (guile)
  96  (lily)
  97  (gnome gtk)
  98  (gnome gtk gdk-event)
  99  (gnome gw libgnomecanvas))
 100
 101
 102 ;;; Lily output interface --- fix silly names and docme
 103
 104 "
 105  The output interface has functions for
 106   * formatting stencils, and
 107   * output commands
 108
 109  Stencils:
 110  beam
 111  bezier-sandwich
 112  bracket
 113  ...
 114
 115  Commands:
 116  define-fonts
 117  header
 118  placebox
 119  ...
 120
 121
 122  The Bare minimum interface for \score { \notes c } } should
 123  implement:
 124
 125     INTERFACE-output-expression
 126     char
 127     filledbox
 128     placebox
 129
 130  and should intercept:
 131 "
 132
 133 (define (dummy . foo) #f)
 134
 135 ;; minimal intercept list:
 136 (define output-interface-intercept
 137   '(
 138     comment
 139     define-fonts
 140     end-output
 141     header
 142     header-end
 143     lily-def
 144     no-origin
 145     output-scopes
 146     start-page
 147     stop-page
 148     start-system
 149     stop-system
 150  ))
 151
 152 (map (lambda (x) (module-define! this-module x dummy))
 153      output-interface-intercept)
 154
 155 (define-public (gnome-output-expression expr port)
 156   (display (dispatch expr) port))
 157
 158 (define (dispatch expr)
 159   (if (pair? expr)
 160       (let ((keyword (car expr)))
 161         (cond
 162          ((eq? keyword 'some-func) "")
 163          ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
 164          (else
 165           (if (module-defined? this-module keyword)
 166               (apply (eval keyword this-module) (cdr expr))
 167               (begin
 168                 (display
 169                  (string-append "undefined: " (symbol->string keyword) "\n"))
 170                 "")))))
 171       expr))
 172
 173 ;; helper functions
 174 (define (stderr string . rest)
 175   (apply format (cons (current-error-port) (cons string rest)))
 176   (force-output (current-error-port)))
 177
 178 (define (item-event item event . data)
 179   (case (gdk-event:type event)
 180     ((enter-notify) (gobject-set-property item 'fill-color "white"))
 181     ((leave-notify) (gobject-set-property item 'fill-color "black"))
 182     ((2button-press) (gobject-set-property item 'fill-color "red")))
 183   #t)
 184
 185 (define (key-press-event item event . data)
 186   (let ((keyval (gdk-event-key:keyval event))
 187         (mods (gdk-event-key:modifiers event)))
 188     (if (and (or (eq? keyval gdk:q)
 189                  (eq? keyval gdk:w))
 190              (equal? mods '(control-mask modifier-mask)))
 191         (gtk-main-quit))
 192     #f))
 193
 194 ;;; Global vars
 195 (define main-window #f)
 196 (define canvas-root #f)
 197
 198 (define system-origin '(0 . 0))
 199
 200 (define canvas-width 400)
 201 (define canvas-height
 202   (inexact->exact (round (* 1.42 canvas-width))))
 203
 204 (define output-scale (* 2 2.83464566929134))
 205 ;;(define output-scale 2.83464566929134)
 206 ;;(define output-scale 1)
 207
 208 (define (char font i)
 209   ;;(text font (make-string 1 (integer->char i))))
 210   (text font "a"))
 211
 212 (define (placebox x y expr)
 213   (let ((item expr))
 214     (if item
 215         (begin
 216           (move item
 217                 (* output-scale (+ (car system-origin) x))
 218                 (* output-scale (- (car system-origin) y)))
 219           (affine-relative item output-scale 0 0 output-scale 0 0)
 220
 221           (gtype-instance-signal-connect item 'event item-event)
 222           item)
 223         #f)))
 224
 225 (define (round-filled-box breapth width depth height blot-diameter)
 226   ;; FIXME: no rounded corners on rectangle
 227   (make <gnome-canvas-rect>
 228     #:parent canvas-root
 229     #:x1 (- breapth) #:y1 (- depth) #:x2 width #:y2 height
 230     #:fill-color "black" #:width-units blot-diameter))
 231
 232 (define (fontify font expr)
 233   #f)
 234
 235 (define (end-output)
 236   (gtk-main))
 237
 238 (define (header . rest)
 239   (let* ((window (make <gtk-window> #:type 'toplevel))
 240          (button (make <gtk-button> #:label "Exit"))
 241          (canvas (make <gnome-canvas>))
 242          (vbox (make <gtk-vbox> #:homogeneous #f))
 243          (scrolled (make <gtk-scrolled-window>)))
 244
 245     (add window vbox)
 246     (add vbox scrolled)
 247     (add scrolled canvas)
 248
 249     (set-size-request button canvas-width 20)
 250     (add vbox button)
 251     (set-child-packing vbox button #f #f 0 'end)
 252
 253     (gtype-instance-signal-connect button 'clicked
 254                                    (lambda (b) (gtk-main-quit)))
 255
 256     ;; papersize
 257     (set-size-request canvas canvas-width canvas-height)
 258     (set-scroll-region canvas 0 0 2000 4000)
 259
 260     (gtype-instance-signal-connect window 'key-press-event key-press-event)
 261
 262     (show-all window)
 263     (set! canvas-root (root canvas))
 264     (set! main-window window)))
 265
 266 (define (text font string)
 267   (make <gnome-canvas-text>
 268     #:parent canvas-root
 269     #:x 0 #:y 0
 270     #:size-points 12
 271     #:size-set #t
 272     #:font "new century schoolbook, i bold 20"
 273     #:fill-color "black"
 274     #:text string))
 275
 276 (define (filledbox a b c d)
 277   (round-filled-box a b c d 0.001))
 278
 279 ;; WTF is this in every backend?
 280 (define (horizontal-line x1 x2 thickness)
 281   ;;(let ((thickness 2))
 282   (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
 283
 284 (define (start-system origin . rest)
 285   (set! system-origin origin))
 286