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 ;;; HIP -- hack in progress
   8 ;;;
   9 ;;; You need:
  10 ;;;
  11 ;;;   * guile-1.6.4 (NOT CVS)
  12 ;;;   * Rotty's g-wrap--tng, possibly Janneke's if you have libffi-3.4.
  13 ;;;
  14 ;;; see also: guile-gtk-general@gnu.org
  15 ;;;
  16 ;;; Try it
  17 ;;;
  18 ;;;   * If using GUILE CVS , then compile LilyPond with GUILE 1.6,
  19 ;;;
  20 ;;;    PATH=/usr/bin/:$PATH ./configure --enable-config=g16  ; make conf=g16
  21 ;;;
  22 ;;;   * Install gnome/gtk development stuff and g-wrap, guile-gnome
  23 ;;;     see buildscripts/guile-gnome.sh
  24 ;;;
  25 ;;;   * Use latin1 encoding for gnome backend, do
  26 ;;;
  27 "
  28        ./configure --prefix=$(pwd) --enable-config=g16
  29        make -C mf conf=g16 clean
  30        make -C mf conf=g16 ENCODING_FILE=$(kpsewhich cork.enc)
  31        (cd mf/out-g16 && mkfontdir)
  32        xset +fp $(pwd)/mf/out-g16
  33 "
  34 ;;;
  35 ;;;   * Setup environment
  36 "
  37 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile
  38 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib
  39 export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f'
  40 "
  41 ;;;  * For GNOME point-and-click, add
  42 ;;;     #(ly:set-point-and-click 'line-column)
  43 ;;;    to your .ly; just click an object on the canvas.
  44 ;;;
  45 ;;;  * Run lily:
  46 "
  47 lilypond-bin -fgnome input/simple-song.ly
  48 "
  49
  50
  51 ;;; TODO:
  52 ;;;  * pango+feta font (see archives gtk-i18n-list@gnome.org and
  53 ;;;    lilypond-devel)
  54 ;;;    - wait for/help with pango 1.6
  55 ;;;    - convert feta to OpenType (CFF) or TrueType (fontforge?)
  56 ;;;    - hack feta20/feta20.pfa?:
  57 ;;;  * font, canvas, scaling?
  58 ;;;  * implement missing stencil functions
  59 ;;;  * implement missing commands
  60 ;;;  * user-interface, keybindings
  61 ;;;  * cleanups: (too many) global vars
  62 ;;;  * papersize, outputscale from book
  63
  64
  65 ;;; SCRIPT moved to buildscripts/guile-gnome.sh
  66
  67 (debug-enable 'backtrace)
  68
  69 ;;(define-module (scm output-gnome))
  70 (define-module (scm output-gnome)
  71   #:export (
  72             char
  73             comment
  74             define-origin
  75             filledbox
  76             horizontal-line
  77             no-origin
  78             placebox
  79             round-filled-box
  80             text
  81             ))
  82
  83 (define this-module (current-module))
  84
  85 (use-modules
  86  (guile)
  87  (ice-9 regex)
  88  (srfi srfi-13)
  89  (lily)
  90  (gnome gtk)
  91
  92  ;; Hmm, <gnome-outputter> is not imported -- but trying this breaks
  93  ;; framework-gnome in a weird way.
  94  ;;(scm framework-gnome))
  95  )
  96
  97 ;; the name of the module will change to canvas rsn
  98 (if (resolve-module '(gnome gw canvas))
  99     (use-modules (gnome gw canvas))
 100     (use-modules (gnome gw libgnomecanvas)))
 101
 102 ;; ughughughughu ughr huh?? -- defined in framework-gnome
 103 (define PIXELS-PER-UNIT 2)
 104 (define-class <gnome-outputter> ()
 105   (page-stencils ;;#:init-value '#()
 106    #:init-keyword #:page-stencils #:accessor page-stencils)
 107   (window #:init-value (make <gtk-window> #:type 'toplevel) #:accessor window)
 108   (scrolled #:init-value (make <gtk-scrolled-window>) #:accessor scrolled)
 109   (canvas #:init-value #f #:accessor canvas)
 110   (page-number #:init-value 0 #:accessor page-number)
 111   (pixels-per-unit #:init-value PIXELS-PER-UNIT #:accessor pixels-per-unit)
 112   (text-items #:init-value '() #:accessor text-items)
 113   (location #:init-value #:f #:accessor location)
 114   (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
 115   (window-width #:init-keyword #:window-width #:accessor window-width)
 116   (window-height #:init-keyword #:window-height #:accessor window-height)
 117   (canvas-width #:init-keyword #:canvas-width #:accessor canvas-width)
 118   (canvas-height #:init-keyword #:canvas-height #:accessor canvas-height))
 119
 120
 121 (define (dummy . foo) #f)
 122
 123 ;; minimal intercept list:
 124 (define output-interface-intercept
 125   '(comment
 126     define-origin
 127     no-origin))
 128
 129 (map (lambda (x) (module-define! this-module x dummy))
 130      output-interface-intercept)
 131
 132 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 133
 134 ;;; output-scale and font-size fun
 135 ;; This used to be:
 136 (define USED-TO-BE-OUTPUT-SCALE 2.83464566929134)
 137 ;; However, it seems that we currently have:
 138 (define 2.3.4-OUTPUT-SCALE 1.75729901757299)
 139 ;; to go from ly-units to <MM/points/whatever?>
 140 ;; Hmm, is this the source of font size problems wrt titling's right margin?
 141
 142 ;;(define pixels-per-unit 1.0)
 143 ;;(define ARBITRARY-OUTPUT-SCALE 5)
 144
 145 ;; Anyway, for on-screen this does not matter: 2 * 2.5 looks fine
 146 (define pixels-per-unit 2.0)
 147 (define ARBITRARY-OUTPUT-SCALE 2.5)
 148
 149 ;;(define output-scale (* OUTPUT-SCALE pixels-per-unit))
 150 (define output-scale (* ARBITRARY-OUTPUT-SCALE pixels-per-unit))
 151
 152
 153
 154 ;; helper functions -- sort this out
 155 (define (stderr string . rest)
 156   ;; debugging
 157   (if #f
 158       (begin
 159         (apply format (cons (current-error-port) (cons string rest)))
 160         (force-output (current-error-port)))))
 161
 162 (define (utf8 i)
 163   (cond
 164    ((< i #x80) (make-string 1 (integer->char i)))
 165    ((< i #x800) (list->string
 166                  (map integer->char
 167                       (list (+ #xc0 (quotient i #x40))
 168                             (+ #x80 (modulo i #x40))))))
 169    ((< i #x10000)
 170     (let ((x (quotient i #x1000))
 171           (y (modulo i #x1000)))
 172       (list->string
 173        (map integer->char
 174             (list (+ #xe0 x)
 175                   (+ #x80 (quotient y #x40))
 176                   (+ #x80 (modulo y #x40)))))))
 177    (else FIXME)))
 178
 179 (define (custom-utf8 i)
 180   (if (< i 80)
 181       (utf8 i)
 182       (utf8 (+ #xee00 i))))
 183
 184 (define (draw-rectangle x1 y1 x2 y2 color width-units)
 185   (make <gnome-canvas-rect>
 186     #:parent (root (canvas go)) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
 187     #:fill-color color #:width-units width-units))
 188
 189
 190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 191 ;;;; stencil outputters
 192 ;;;;
 193
 194 (define (char font i)
 195   (text font (utf8 i)))
 196
 197 (define (placebox x y expr)
 198   (stderr "item: ~S\n" expr)
 199   (let ((item expr))
 200     ;;(if item
 201     ;; FIXME ugly hack to skip #unspecified ...
 202     (if (and item (not (eq? item (if #f #f))))
 203         (begin
 204           (move item
 205                 (* output-scale (+ (car system-origin) x))
 206                 (* output-scale (- (car system-origin) y)))
 207           (affine-relative item output-scale 0 0 output-scale 0 0)
 208
 209           (gtype-instance-signal-connect item 'event item-event)
 210           (if (location go)
 211               (hashq-set! (item-locations go) item (location go)))
 212           item)
 213         #f)))
 214
 215 (define (round-filled-box breapth width depth height blot-diameter)
 216   ;; FIXME: no rounded corners on rectangle...
 217   ;; FIXME: blot?
 218   (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter))
 219
 220 (define (pango-font-name font)
 221   (cond
 222    ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
 223     "lilypond-feta, regular 32")
 224    (else
 225     "ecrm12")))
 226     ;;(ly:font-name font))))
 227     ;;(ly:font-filename font))))
 228
 229 (define (pango-font-size font)
 230   (let* ((designsize (ly:font-design-size font))
 231          (magnification (* (ly:font-magnification font)))
 232
 233          ;; experimental sizing:
 234          ;; where does factor come from?
 235          ;;
 236          ;; 0.435 * (12 / 20) = 0.261
 237          ;; 2.8346456692913/ 0.261 = 10.86071137659501915708
 238          ;;(ops (* 0.435 (/ 12 20) (* output-scale pixels-per-unit)))
 239          ;; for size-points
 240          (ops 2.61)
 241
 242          (scaling (* ops magnification designsize)))
 243     (stderr "OPS:~S\n" ops)
 244     (stderr "scaling:~S\n" scaling)
 245     (stderr "magnification:~S\n" magnification)
 246     (stderr "design:~S\n" designsize)
 247
 248     scaling))
 249
 250 ;;font-name: "GNU-LilyPond-feta-20"
 251 ;;font-filename: "feta20"
 252 ;;pango-font-name: "lilypond-feta, regular 32"
 253 ;;OPS:2.61
 254 ;;scaling:29.7046771653543
 255 ;;magnification:0.569055118110236
 256 ;;design:20.0
 257
 258 (define (text font string)
 259   (stderr "font-name: ~S\n" (ly:font-name font))
 260   ;; TODO s/filename/file-name/
 261   (stderr "font-filename: ~S\n" (ly:font-filename font))
 262
 263   (stderr "pango-font-name: ~S\n" (pango-font-name font))
 264   (stderr "pango-font-size: ~S\n" (pango-font-size font))
 265   (let ((item
 266          (make <gnome-canvas-text>
 267            #:parent (root (canvas go))
 268
 269            ;; experimental text placement corrections.
 270            ;; UGHR?  What happened to tex offsets?  south-west?
 271            ;; is pango doing something 'smart' wrt baseline ?
 272            #:anchor 'south-west
 273            #:x 0.003 #:y 0.123
 274
 275            ;;
 276            ;;#:anchor 'west
 277            ;;#:x 0.015 #:y -3.71
 278
 279            #:font (pango-font-name font)
 280
 281            #:size-points (pango-font-size font)
 282            ;;#:size ...
 283            #:size-set #t
 284
 285            ;;apparently no effect :-(
 286            ;;#:scale 1.0
 287            ;;#:scale-set #t
 288
 289            #:fill-color "black"
 290            #:text string)))
 291     (set! (text-items go) (cons item (text-items go)))
 292     item))
 293
 294 (define (filledbox a b c d)
 295   (round-filled-box a b c d 0.001))
 296
 297 ;; WTF is this in every backend?
 298 (define (horizontal-line x1 x2 thickness)
 299   ;;(let ((thickness 2))
 300   (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
 301
 302 ;; origin -- bad name
 303 (define (define-origin file line col)
 304   ;; ughr, why is this not passed as [part of] stencil object
 305   (set! (location go) (if (procedure? point-and-click)
 306                           ;; duh, only silly string append
 307                           ;; (point-and-click line col file)
 308                           (list line col file)
 309                           #f)))