scm/sketch.scm

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