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.5)\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.5)\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.5)\n"
 113 ;; urg, Sketch can't handle non-text fonts
 114 ;;          "Fn('" global-font "')\n"
 115             "Fn('Times-Roman')\n"
 116             "Fs(12)\n"
 117             "txt('" ,(ascii->string i) "',("
 118             (sk-numbers->string (list (* global-scale global-x)
 119                                       (* global-scale global-y)))
 120             "))\n")))
 121
 122   (define (hairpin thick width starth endh )
 123     (string-append
 124      (numbers->string (list width starth endh thick))
 125      " draw_hairpin"))
 126
 127   ;; what the heck is this interface ?
 128   (define (dashed-slur thick dash l)
 129     (string-append
 130      (apply string-append (map control->string l))
 131      (ly-number->string thick)
 132      " [ "
 133      (ly-number->string dash)
 134      " "
 135      (ly-number->string (* 10 thick))   ;UGH.  10 ?
 136      " ] 0 draw_dashed_slur"))
 137
 138   (define (dashed-line thick on off dx dy)
 139     (string-append
 140      (ly-number->string dx)
 141      " "
 142      (ly-number->string dy)
 143      " "
 144      (ly-number->string thick)
 145      " [ "
 146      (ly-number->string on)
 147      " "
 148      (ly-number->string off)
 149      " ] 0 draw_dashed_line"))
 150
 151   (define (repeat-slash wid slope thick)
 152    (string-append (numbers->string (list wid slope thick))
 153     " draw_repeat_slash"))
 154
 155   (define (end-output)
 156     "guidelayer('Guide Lines',1,0,0,1,(0,0,1))
 157 grid((0,0,20,20),0,(0,0,1),'Grid')\n")
 158
 159   (define (experimental-on) "")
 160
 161   (define (font-switch i)
 162     "")
 163
 164   (define (header-end)
 165     "")
 166
 167   (define (lily-def key val)
 168     (if (equal? key "lilypondpaperoutputscale")
 169         (set! global-scale (string->number val)))
 170     "")
 171
 172
 173   (define (header creator generate)
 174     (string-append
 175      "##Sketch 1 2
 176 document()
 177 layout('A4',0)
 178 layer('Layer 1',1,1,0,0,(0,0,0))
 179 "))
 180
 181   (define (invoke-char s i)
 182     "")
 183
 184   (define (invoke-dim1 s d)
 185     (string-append
 186      (ly-number->string (* d  (/ 72.27 72))) " " s ))
 187
 188   ;;  urg
 189   (define (placebox x y s)
 190 ;;    (format (current-error-port) "placebox: ~S, ~S, ~S\n" x y s)
 191     (set! global-x (+ x 0))
 192     (set! global-y (+ y 100))
 193     (let ((s (primitive-eval global-s)))
 194       (set! global-s "\n")
 195       s))
 196
 197   (define (bezier-sandwich l thick)
 198     (let ((s (list
 199               'global-beziers
 200               'global-list
 201               thick)))
 202       (set! global-s s)
 203       (set! global-list l))
 204     "\n")
 205
 206 ; TODO: use HEIGHT argument
 207   (define (start-line height)
 208      "G()\n"
 209      )
 210
 211   ;;  r((520.305,0,0,98.0075,51.8863,10.089))
 212   ;;  width, 0, 0, height, x, y
 213   (define (filledbox breapth width depth height)
 214     (let ((s (list
 215               'global-filledbox
 216               (+ breapth width)
 217               0 0
 218               (+ depth height)
 219               `(- global-x ,breapth)
 220               `(- global-y ,depth))))
 221 ;;      (format (current-error-port) "filledbox: ~S\n" s)
 222       (set! global-s s))
 223     "\n")
 224
 225   (define (stem x y z w) (filledbox x y z w))
 226
 227
 228   (define (stop-line)
 229       "G_()\n")
 230
 231   (define (text s)
 232     (set! global-s
 233           `(string-append "txt('" ,s "',("
 234                           (sk-numbers->string (list global-x global-y))
 235                           "))\n")))
 236
 237
 238   (define (volta h w thick vert_start vert_end)
 239     (string-append
 240      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 241      " draw_volta"))
 242
 243   (define (tuplet ht gap dx dy thick dir)
 244     (string-append
 245      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 246      " draw_tuplet"))
 247
 248
 249   (define (unknown)
 250     "\n unknown\n")
 251
 252   (define (ez-ball ch letter-col ball-col)
 253     (string-append
 254      " (" ch ") "
 255      (numbers->string (list letter-col ball-col))
 256      " /Helvetica-Bold " ;; ugh
 257      " draw_ez_ball"))
 258
 259   (define (define-origin a b c ) "")
 260   (define (no-origin) "")
 261
 262   ;; PS
 263   (cond ((eq? action-name 'all-definitions)
 264          `(begin
 265             (define beam ,beam)
 266             (define tuplet ,tuplet)
 267             (define bracket ,bracket)
 268             (define char ,char)
 269             (define hairpin ,hairpin)
 270             (define volta ,volta)
 271             (define bezier-sandwich ,bezier-sandwich)
 272             (define dashed-line ,dashed-line)
 273             (define dashed-slur ,dashed-slur)
 274             (define end-output ,end-output)
 275             (define experimental-on ,experimental-on)
 276             (define filledbox ,filledbox)
 277             (define stem ,stem)
 278             (define font-def ,font-def)
 279             (define font-switch ,font-switch)
 280             (define header-end ,header-end)
 281             (define lily-def ,lily-def)
 282             (define font-load-command ,font-load-command)
 283             (define header ,header)
 284             (define invoke-char ,invoke-char)
 285             (define invoke-dim1 ,invoke-dim1)
 286             (define placebox ,placebox)
 287             (define select-font ,select-font)
 288             (define start-line ,start-line)
 289             (define stem ,stem)
 290             (define stop-line ,stop-line)
 291             (define stop-last-line ,stop-line)
 292             (define repeat-slash ,repeat-slash)
 293             (define text ,text)
 294             (define no-origin ,no-origin)
 295             (define define-origin ,define-origin)
 296             (define ez-ball ,ez-ball)
 297             ))
 298         ((eq? action-name 'repeat-slash) repeat-slash)
 299         ((eq? action-name 'tuplet) tuplet)
 300         ((eq? action-name 'beam) beam)
 301         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 302         ((eq? action-name 'bracket) bracket)
 303         ((eq? action-name 'char) char)
 304         ((eq? action-name 'dashed-line) dashed-line)
 305         ((eq? action-name 'dashed-slur) dashed-slur)
 306         ((eq? action-name 'hairpin) hairpin)
 307         ((eq? action-name 'experimental-on) experimental-on)
 308         ((eq? action-name 'filledbox) filledbox)
 309         ((eq? action-name 'ez-ball) ez-ball)
 310         ((eq? action-name 'select-font) select-font)
 311         ((eq? action-name 'volta) volta)
 312         (else (error "unknown tag -- SKETCH-SCM " action-name))
 313         )
 314   )