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