scm/sketch.scm

   1
   2
   3 ;;; urg.
   4 (define (sk-numbers->string l)
   5   (string-append
   6    (number->string (car l))
   7    (if (null? (cdr l))
   8        ""
   9        (string-append ","  (sk-numbers->string (cdr l)))
  10        )
  11    )
  12   )
  13
  14
  15 (define (sketch-scm action-name)
  16   (define global-x 0.0)
  17   (define global-y 0.0)
  18   (define output-scale 1.0)
  19   (define (mul-scale  x) (* output-scale x))
  20
  21   ;; alist containing fontname -> fontcommand assoc (both strings)
  22   (define font-alist '())
  23   (define font-count 0)
  24   (define current-font "")
  25
  26
  27   (define (cached-fontname i)
  28     (string-append
  29      "lilyfont"
  30      (make-string 1 (integer->char (+ 65 i)))))
  31
  32
  33   (define (select-font name-mag-pair)
  34     (let*
  35         (
  36          (c (assoc name-mag-pair font-name-alist))
  37          )
  38
  39       (if (eq? c #f)
  40           (begin
  41             (display "FAILED\n")
  42             (display (object-type (car name-mag-pair)))
  43             (display (object-type (caaar font-name-alist)))
  44
  45             (ly-warn (string-append
  46                       "Programming error: No such font known "
  47                       (car name-mag-pair) " "
  48                       (ly-number->string (cdr name-mag-pair))
  49                       ))
  50
  51             "") ; issue no command
  52           "")
  53 ;         (string-append " " (cddr c) " "))
  54       ))
  55
  56     (define (font-load-command name-mag command)
  57       "")
  58
  59 ;      "Fn(" command ")" )
  60
  61   (define (beam width slope thick)
  62     (string-append
  63      (sk-numbers->string (list slope width thick)) " draw_beam" ))
  64
  65   (define (comment s)
  66     (string-append "% " s))
  67
  68   (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
  69     (string-append
  70      (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
  71
  72   (define (char i)
  73     (invoke-char " show" i))
  74
  75
  76   (define (hairpin thick width starth endh )
  77     (string-append
  78      (numbers->string (list width starth endh thick))
  79      " draw_hairpin"))
  80
  81   ;; what the heck is this interface ?
  82   (define (dashed-slur thick dash l)
  83     (string-append
  84      (apply string-append (map control->string l))
  85      (ly-number->string thick)
  86      " [ "
  87      (ly-number->string dash)
  88      " "
  89      (ly-number->string (* 10 thick))   ;UGH.  10 ?
  90      " ] 0 draw_dashed_slur"))
  91
  92   (define (dashed-line thick on off dx dy)
  93     (string-append
  94      (ly-number->string dx)
  95      " "
  96      (ly-number->string dy)
  97      " "
  98      (ly-number->string thick)
  99      " [ "
 100      (ly-number->string on)
 101      " "
 102      (ly-number->string off)
 103      " ] 0 draw_dashed_line"))
 104
 105   (define (repeat-slash wid slope thick)
 106    (string-append (numbers->string (list wid slope thick))
 107     " draw_repeat_slash"))
 108
 109   (define (end-output)
 110     "guidelayer('Guide Lines',1,0,0,1,(0,0,1))
 111 grid((0,0,20,20),0,(0,0,1),'Grid')\n")
 112
 113   (define (experimental-on) "")
 114
 115   ;; obsolete?
 116   (define (font-def i s)
 117     (string-append
 118      "\n/" (font i) " {/"
 119      (substring s 0 (- (string-length s) 4))
 120      " findfont 12 scalefont setfont} bind def \n"))
 121
 122   (define (font-switch i)
 123     "")
 124 ;    (string-append (font i) " "))
 125
 126   (define (header-end)
 127     (string-append "")
 128
 129     )
 130
 131   (define (lily-def key val)
 132     (if (equal? key "lilypondpaperoutputscale")
 133         (set! output-scale (string->number val))
 134 )
 135     "")
 136
 137
 138   (define (header creator generate)
 139     (string-append
 140      "##Sketch 1 2
 141 document()
 142 layout('A4',0)
 143 layer('Layer 1',1,1,0,0,(0,0,0))
 144 "))
 145
 146   (define (invoke-char s i)
 147     "")
 148
 149   (define (invoke-dim1 s d)
 150     (string-append
 151      (ly-number->string (* d  (/ 72.27 72))) " " s ))
 152
 153   (define (placebox x y s)
 154     (set! global-x (+ x 0))
 155     (set! global-y (+ y 100))
 156     (eval s)
 157     )
 158
 159   (define (bezier-sandwich l thick)
 160     '(string-append
 161      (apply string-append (map control->string l))
 162      (ly-number->string  thick)
 163      " draw_bezier_sandwich"))
 164
 165 ; TODO: use HEIGHT argument
 166   (define (start-line height)
 167      "G()\n"
 168      )
 169
 170   (define (filledbox breapth width depth height)
 171     `(string-append
 172       "lw(1)\nr("
 173       (sk-numbers->string (quote ,(map  mul-scale (list (+ breapth width)
 174                                                  0 0
 175                                                  (- (+ breapth depth))
 176                                                  global-x
 177                                                  (+ global-y height)))))
 178                     ")\n")
 179     )
 180
 181   (define (stem x y z w) (filledbox x y z w))
 182
 183
 184   (define (stop-line)
 185       "G_()\n")
 186
 187   (define (text s)
 188     "")
 189 ;    (string-append "(" s ") show  "))
 190
 191
 192   (define (volta h w thick vert_start vert_end)
 193     (string-append
 194      (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
 195      " draw_volta"))
 196
 197   (define (tuplet ht gap dx dy thick dir)
 198     (string-append
 199      (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
 200      " draw_tuplet"))
 201
 202
 203   (define (unknown)
 204     "\n unknown\n")
 205
 206   (define (ez-ball ch letter-col ball-col)
 207     (string-append
 208      " (" ch ") "
 209      (numbers->string (list letter-col ball-col))
 210      " /Helvetica-Bold " ;; ugh
 211      " draw_ez_ball"))
 212
 213   (define (define-origin a b c ) "")
 214   (define (no-origin) "")
 215
 216   ;; PS
 217   (cond ((eq? action-name 'all-definitions)
 218          `(begin
 219             (define beam ,beam)
 220             (define tuplet ,tuplet)
 221             (define bracket ,bracket)
 222             (define char ,char)
 223             (define hairpin ,hairpin)
 224             (define volta ,volta)
 225             (define bezier-sandwich ,bezier-sandwich)
 226             (define dashed-line ,dashed-line)
 227             (define dashed-slur ,dashed-slur)
 228             (define end-output ,end-output)
 229             (define experimental-on ,experimental-on)
 230             (define filledbox ,filledbox)
 231             (define stem ,stem)
 232             (define font-def ,font-def)
 233             (define font-switch ,font-switch)
 234             (define header-end ,header-end)
 235             (define lily-def ,lily-def)
 236             (define font-load-command ,font-load-command)
 237             (define header ,header)
 238             (define invoke-char ,invoke-char)
 239             (define invoke-dim1 ,invoke-dim1)
 240             (define placebox ,placebox)
 241             (define select-font ,select-font)
 242             (define start-line ,start-line)
 243             (define stem ,stem)
 244             (define stop-line ,stop-line)
 245             (define stop-last-line ,stop-line)
 246             (define repeat-slash ,repeat-slash)
 247             (define text ,text)
 248             (define no-origin ,no-origin)
 249             (define define-origin ,define-origin)
 250             (define ez-ball ,ez-ball)
 251             ))
 252         ((eq? action-name 'repeat-slash) repeat-slash)
 253         ((eq? action-name 'tuplet) tuplet)
 254         ((eq? action-name 'beam) beam)
 255         ((eq? action-name 'bezier-sandwich) bezier-sandwich)
 256         ((eq? action-name 'bracket) bracket)
 257         ((eq? action-name 'char) char)
 258         ((eq? action-name 'dashed-line) dashed-line)
 259         ((eq? action-name 'dashed-slur) dashed-slur)
 260         ((eq? action-name 'hairpin) hairpin)
 261         ((eq? action-name 'experimental-on) experimental-on)
 262         ((eq? action-name 'filledbox) filledbox)
 263         ((eq? action-name 'ez-ball) ez-ball)
 264         ((eq? action-name 'select-font) select-font)
 265         ((eq? action-name 'volta) volta)
 266         (else (error "unknown tag -- SKETCH-SCM " action-name))
 267         )
 268   )