scm/sketch.scm

   1
   2
   3
   4 (use-modules (ice-9 format))
   5
   6 (define (ascii->string i) (make-string 1 (integer->char i)))
   7
   8 (define (control->list c)
   9   (list (+ global-x (car c)) (+ global-y (cdr c))))
  10
  11 (define (control-flip-y c)
  12   (cons (car c) (* -1 (cdr c))))
  13
  14 ;;; urg.
  15 (define (sk-numbers->string l)
  16   (string-append
  17    (number->string (car l))
  18    (if (null? (cdr l))
  19        ""
  20        (string-append ","  (sk-numbers->string (cdr l))))))
  21
  22 (define global-x 0.0)
  23 (define global-y 0.0)
  24 (define global-list '())
  25 (define global-font "")
  26 (define global-s "")
  27 (define global-scale 1.0)
  28 (define (global-mul-scale  x) (* global-scale x))
  29
  30 ;; hmm, global is global
  31 (define (global-filledbox width dy dx height x y)
  32   (string-append
  33    "fp((0,0,0))\n"
  34    "lw(0.1)\n"
  35    "r("
  36    (sk-numbers->string
  37     (map global-mul-scale (list width dy dx height x y)))
  38    ")\n"))
  39
  40 (define (global-bezier l)
  41   (let* ((c0 (car (list-tail l 3)))
  42          (c123 (list-head l 3))
  43          (start (control->list c0))
  44          (control (apply append (map control->list c123))))
  45     (string-append
  46      "bs(" (sk-numbers->string (map global-mul-scale start)) ",0)\n"
  47      "bc(" (sk-numbers->string (map global-mul-scale control)) ",2)\n")))
  48
  49
  50 (define (global-beziers l thick)
  51   (let* (;;(burp (set! global-y (+ global-y (* 2 (cdar l)))))
  52          (first
  53           (list-tail l 4))
  54          (second
  55           (list-head l 4))
  56                  )
  57     (string-append
  58      "fp((0,0,0))\n"
  59      "lw(0.1)\n"
  60      "b()\n"
  61      (global-bezier first)
  62      (global-bezier second)
  63      ;;"b_()\n"
  64      )))
  65
  66
  67 (define (sketch-scm action-name)
  68
  69   ;; alist containing fontname -> fontcommand assoc (both strings)
  70   (define font-alist '())
  71   (define font-count 0)
  72   (define current-font "")
  73
  74   (define (font-def x)
  75   "")
  76
  77   (define (cached-fontname i)
  78     "")
  79
  80   (define (select-font name-mag-pair)
  81     (set! global-font (car name-mag-pair))
  82     "")
  83
  84   (define (font-load-command name-mag command)
  85     "")
  86
  87   (define (beam width slope thick)
  88     (let ((s (list
  89               'global-filledbox
  90               width
  91               (* slope width)
  92               0
  93               thick
  94               'global-x
  95               'global-y)))
  96       (set! global-s s))
  97     "\n")
  98
  99   (define (comment s)
 100     (string-append "% " s))
 101
 102   (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
 103     (string-append
 104      (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
 105
 106   (define (char i)
 107     (set! global-s
 108 ;;        `(string-append "txt(" ,(number->string i) ",("
 109 ;;                        (sk-numbers->string (list global-x global-y))
 110           `(string-append
 111             "fp((0,0,0))\n"
 112             "le()\n"
 113             "lw(0.1)\n"
 114 ;;          "Fn('" global-font "')\n"
 115 ;;          "Fn('Times-Roman')\n"
 116             "Fn('TeX-feta20')\n"
 117             "Fs(20)\n"
 118             ;; chars > 128 don't work yet
 119             "txt('" ,(ascii->string (modulo i 128)) "',("
 120 ;;          "char(" ,(number->string i)  ",("
 121             (sk-numbers->string (list (* global-scale global-x)
 122                                       (* global-scale global-y)))
 123             "))\n")))
 124
 125   (define (hairpin thick width starth endh )
 126     (string-append
 127      (numbers->string (list width starth endh thick))
 128      " draw_hairpin"))
 129
 130   ;; what the heck is this interface ?
 131   (define (dashed-slur thick dash l)
 132     (string-append
 133      (apply string-append (map control->string l))
 134      (ly-number->string thick)
 135      " [ "
 136      (ly-number->string dash)
 137      " "
 138      (ly-number->string (* 10 thick))   ;UGH.  10 ?
 139      " ] 0 draw_dashed_slur"))
 140
 141   (define (dashed-line thick on off dx dy)
 142     (string-append
 143      (ly-number->string dx)
 144      " "
 145      (ly-number->string dy)
 146      " "
 147      (ly-number->string thick)
 148      " [ "
 149      (ly-number->string on)
 150      " "
 151      (ly-number->string off)
 152      " ] 0 draw_dashed_line"))
 153
 154   (define (repeat-slash wid slope thick)
 155    (string-append (numbers->string (list wid slope thick))
 156     " draw_repeat_slash"))
 157
 158   (define (end-output)
 159     "guidelayer('Guide Lines',1,0,0,1,(0,0,1))
 160 grid((0,0,20,20),0,(0,0,1),'Grid')\n")
 161
 162   (define (experimental-on) "")
 163
 164   (define (font-switch i)
 165     "")
 166
 167   (define (header-end)
 168     "")
 169
 170   (define (lily-def key val)
 171     (if (equal? key "lilypondpaperoutputscale")
 172         (set! global-scale (string->number val)))
 173     "")
 174
 175
 176   (define (header creator generate)
 177     (string-append
 178      "##Sketch 1 2
 179 document()
 180 layout('A4',0)
 181 layer('Layer 1',1,1,0,0,(0,0,0))
 182 "))
 183
 184   (define (invoke-char s i)
 185     "")
 186
 187   (define (invoke-dim1 s d)
 188     (string-append
 189      (ly-number->string (* d  (/ 72.27 72))) " " s ))
 190
 191   ;;  urg
 192   (define (placebox x y s)
 193 ;;    (format (current-error-port) "placebox: ~S, ~S, ~S\n" x y s)
 194     (set! global-x (+ x 0))
 195     (set! global-y (+ y 100))
 196     (let ((s (primitive-eval global-s)))
 197       (set! global-s "\n")
 198       s))
 199
 200   (define (bezier-sandwich l thick)
 201     (let ((s (list
 202               'global-beziers
 203               'global-list
 204               thick)))
 205       (set! global-s s)
 206       (set! global-list l))
 207     "\n")
 208
 209 ; TODO: use HEIGHT argument
 210   (define (start-line height)
 211      "G()\n"
 212      )
 213
 214   ;;  r((520.305,0,0,98.0075,51.8863,10.089))
 215   ;;  width, 0, 0, height, x, y
 216   (define (filledbox breapth width depth height)
 217     (let ((s (list
 218               'global-filledbox
 219               (+ breapth width)
 220               0 0
 221               (+ depth height)
 222               `(- global-x ,breapth)
 223               `(- global-y ,depth))))
 224 ;;      (format (current-error-port) "filledbox: ~S\n" s)
 225       (set! global-s s))
 226     "\n")
 227
 228   (define (stem x y z w) (filledbox x y z w))
 229
 230
 231   (define (stop-line)
 232       "G_()\n")
 233
 234   (define (text s)
 235     (set! global-s
 236           `(string-append "txt('" ,s "',("
 237                           (sk-numbers->string (list global-x global-y))
 238                           "))\n")))
 239
 240
 241   (define (volta h w thick vert_start vert_end)
 242     (string-append
 243      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 244      " draw_volta"))
 245
 246   (define (tuplet ht gap dx dy thick dir)
 247     (string-append
 248      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 249      " draw_tuplet"))
 250
 251
 252   (define (unknown)
 253     "\n unknown\n")
 254
 255   (define (ez-ball ch letter-col ball-col)
 256     (string-append
 257      " (" ch ") "
 258      (numbers->string (list letter-col ball-col))
 259      " /Helvetica-Bold " ;; ugh
 260      " draw_ez_ball"))
 261
 262   (define (define-origin a b c ) "")
 263   (define (no-origin) "")
 264
 265   ;; PS
 266   (cond ((eq? action-name 'all-definitions)
 267          `(begin
 268             (define beam ,beam)
 269             (define tuplet ,tuplet)
 270             (define bracket ,bracket)
 271             (define char ,char)
 272             (define hairpin ,hairpin)
 273             (define volta ,volta)
 274             (define bezier-sandwich ,bezier-sandwich)
 275             (define dashed-line ,dashed-line)
 276             (define dashed-slur ,dashed-slur)
 277             (define end-output ,end-output)
 278             (define experimental-on ,experimental-on)
 279             (define filledbox ,filledbox)
 280             (define stem ,stem)
 281             (define font-def ,font-def)
 282             (define font-switch ,font-switch)
 283             (define header-end ,header-end)
 284             (define lily-def ,lily-def)
 285             (define font-load-command ,font-load-command)
 286             (define header ,header)
 287             (define invoke-char ,invoke-char)
 288             (define invoke-dim1 ,invoke-dim1)
 289             (define placebox ,placebox)
 290             (define select-font ,select-font)
 291             (define start-line ,start-line)
 292             (define stem ,stem)
 293             (define stop-line ,stop-line)
 294             (define stop-last-line ,stop-line)
 295             (define repeat-slash ,repeat-slash)
 296             (define text ,text)
 297             (define no-origin ,no-origin)
 298             (define define-origin ,define-origin)
 299             (define ez-ball ,ez-ball)
 300             ))
 301         ((eq? action-name 'repeat-slash) repeat-slash)
 302         ((eq? action-name 'tuplet) tuplet)
 303         ((eq? action-name 'beam) beam)
 304         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 305         ((eq? action-name 'bracket) bracket)
 306         ((eq? action-name 'char) char)
 307         ((eq? action-name 'dashed-line) dashed-line)
 308         ((eq? action-name 'dashed-slur) dashed-slur)
 309         ((eq? action-name 'hairpin) hairpin)
 310         ((eq? action-name 'experimental-on) experimental-on)
 311         ((eq? action-name 'filledbox) filledbox)
 312         ((eq? action-name 'ez-ball) ez-ball)
 313         ((eq? action-name 'select-font) select-font)
 314         ((eq? action-name 'volta) volta)
 315         (else (error "unknown tag -- SKETCH-SCM " action-name))
 316         )
 317   )
 318
 319