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 ;;; Note: this install information is volatile
  11 ;;;       you'll probably want to pull all from
  12 ;;;       from guile-gnome-devel@gnu.org--2004 soon
  13 ;;;
  14 ;;; move this into workbook?
  15
  16 "
  17 ## install gnome-devel
  18
  19 ## use guile-1.6 for g-wrap/guile-gnome
  20 PATH=/usr/bin:$PATH
  21
  22 ## get g-wrap 2.0
  23 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
  24
  25 rm -rf gw-pristine
  26 tla get a.rottmann@gmx.at--2004-main/g-wrap--tng gw-pristine
  27 cd gw-pristine
  28
  29 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  30 mkdir =build
  31 cd =build
  32 ../configure --prefix=$HOME/usr/pkg/g-wrap
  33 make install
  34
  35 cd ../..
  36
  37 ## get guile-gnome
  38 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
  39 rm -rf guile-gnome
  40 tla guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
  41 cd guile-gnome
  42 tla build-config -r configs/gnu.org/dev
  43 cd src
  44 ## ugh: get janneke's stuff -- should make build-config, I guess?
  45 tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true
  46 rm -rf defs
  47 rm -rf libgnomecanvas
  48 tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 libgnomecanvas
  49 tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 defs
  50
  51 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
  52 mkdir ../=build
  53 cd ../=build
  54
  55 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
  56 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
  57 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
  58
  59 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
  60
  61 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
  62 #FIXME: fixup
  63 (cd $HOME/usr/pkg/guile-gnome/share/guile/gnome && mv gtk/g[dt]k.scm gw)
  64
  65 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
  66 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
  67 guile -s ../src/gtk/examples/hello.scm
  68
  69
  70 lilypond-bin -fgnome input/simple-song.ly
  71
  72
  73 "
  74
  75
  76
  77 (debug-enable 'backtrace)
  78
  79 (define-module (scm output-gnome))
  80 (define this-module (current-module))
  81
  82 (use-modules
  83  (guile)
  84  (lily)
  85  (gnome gtk)
  86  (gnome gw libgnomecanvas))
  87
  88
  89 ;;; Lily output interface --- fix silly names and docme
  90
  91 "
  92  The output interface has functions for
  93   * formatting stencils, and
  94   * output commands
  95
  96  Stencils:
  97  beam
  98  bezier-sandwich
  99  bracket
 100  ...
 101
 102  Commands:
 103  define-fonts
 104  header
 105  placebox
 106  ...
 107
 108
 109  The Bare minimum interface for \score { \notes c } } should
 110  implement:
 111
 112     INTERFACE-output-expression
 113     char
 114     filledbox
 115     placebox
 116
 117  and should intercept:
 118 "
 119
 120 (define (dummy . foo) #f)
 121
 122 ;; minimal intercept list:
 123 (define output-interface-intercept
 124   '(
 125     comment
 126     define-fonts
 127     end-output
 128     header
 129     header-end
 130     lily-def
 131     no-origin
 132     output-scopes
 133     start-page
 134     stop-page
 135     start-system
 136     stop-system
 137  ))
 138
 139 (map (lambda (x) (module-define! this-module x dummy))
 140      output-interface-intercept)
 141
 142 (define-public (gnome-output-expression expr port)
 143   (display (dispatch expr) port))
 144
 145 (define (dispatch expr)
 146   (let ((keyword (car expr)))
 147     (cond
 148      ((eq? keyword 'some-func) "")
 149      ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
 150      (else
 151       (if (module-defined? this-module keyword)
 152           (apply (eval keyword this-module) (cdr expr))
 153           (begin
 154             (display
 155              (string-append "undefined: " (symbol->string keyword) "\n"))
 156             ""))))))
 157
 158
 159 ;;; Global vars
 160 (define main-window #f)
 161 (define canvas-root #f)
 162
 163 (define output-scale (* 2 2.83464566929134))
 164 (define system-y 0)
 165 (define line-thickness 0.001)
 166
 167
 168 (define (char font i)
 169   (let ((item (make <gnome-canvas-text> #:x 0 #:y 0
 170                     #:font "new century schoolbook, i bold 20"
 171                     #:text (char->string i))))
 172     (add canvas-root txt)))
 173
 174 (define (placebox x y expr)
 175   #f)
 176
 177 ;; gnome_canvas_item_new (gnome_canvas_root (canvas),
 178 ;;  gnome_canvas_rect_get_type (),
 179 ;;  "x1", (double) x1,
 180 ;;  "y1", (double) y1,
 181 ;;  "x2", (double) x2,
 182 ;;  "y2", (double) y2,
 183 ;;  "fill_color", "black",
 184 ;;  "outline_color", "black",
 185 ;;  "width_units", 1.0,
 186 ;;  NULL);
 187
 188 (define (round-filled-box breapth width depth height blot-diameter)
 189   (let* ((x1 . ,(number->string (* output-scale (- 0 breapth))))
 190          (y1 . ,(number->string (* output-scale (- 0 height))))
 191          (x2 . ,(number->string (* output-scale width)))
 192          (y2 . ,(number->string (* output-scale height)))
 193          ;;(ry . ,(number->string (/ blot-diameter 2)))
 194          ;; FIXME: no rounded corners on rectangle
 195          (item (make <gnome-canvas-rect>
 196                  #:x1 x1 #:y1 y1 #:x2 x2.0 #:y2 y2
 197                  ;;#:width-unit blot-diameter
 198                  )))
 199     (add canvas-root item)))
 200
 201 (define (fontify font expr)
 202   #f)
 203
 204 (define (end-output)
 205   (gtk-main))
 206
 207 (define (header . rest)
 208   (let* ((window (make <gtk-window> #:type 'toplevel))
 209          (button (make <gtk-button> #:label "Exit"))
 210          (canvas (make <gnome-canvas> ))
 211          (vbox (make <gtk-vbox>)))
 212
 213     (gtk-container-add window vbox)
 214     (gtk-widget-show vbox)
 215
 216     (set-size-request canvas 300 300)
 217     (gtk-container-add vbox canvas)
 218
 219     (gtk-container-add vbox button)
 220     (gtype-instance-signal-connect button 'clicked
 221                                    (lambda (b) (gtk-main-quit)))
 222
 223     (gtk-widget-show canvas)
 224     (gtk-widget-show button)
 225     (gtk-widget-show window)
 226
 227     (set! canvas-root (root canvas))
 228     (set! main-window window)))
 229
 230 (define (text font string)
 231   (let ((item (make <gnome-canvas-text> #:x 0 #:y 0
 232                     #:font "new century schoolbook, i bold 20"
 233                     #:text string)))
 234     (add canvas-root txt)))
 235
 236 (define (filledbox a b c d)
 237   (round-filled-box a b c d 0.001))
 238
 239 ;; WTF is this in every backend?
 240 (define (horizontal-line x1 x2 th)
 241   (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))