+;;; sketch.scm -- implement Scheme output routines for Sketch
+;;;
+;;; source file of the GNU LilyPond music typesetter
+;;;
+;;; (c) 1998--2001 Jan Nieuwenhuizen <janneke@gnu.org>
+;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+
+(define-module (scm sketch)
+ :export (sketch-output-expression)
+ :no-backtrace
+ )
+
+(define this-module (current-module))
+
+(define (sketch-output-expression expr port)
+ (display (eval expr this-module) port)
+ )
+
+
+(use-modules
+ (guile)
+ (guile-user))
+
+
+(use-modules (ice-9 format))
+
+(define (ascii->string i) (make-string 1 (integer->char i)))
+
+(define (control->list c)
+ (list (+ global-x (car c)) (+ global-y (cdr c))))
+
+(define (control-flip-y c)
+ (cons (car c) (* -1 (cdr c))))
+
+;;; urg.
+(define (sk-numbers->string l)
+ (string-append
+ (number->string (car l))
+ (if (null? (cdr l))
+ ""
+ (string-append "," (sk-numbers->string (cdr l))))))
+
+(define global-x 0.0)
+(define global-y 0.0)
+(define global-list '())
+(define global-font "")
+(define global-s "")
+(define global-scale 1.0)
+(define (global-mul-scale x) (* global-scale x))
+
+;; hmm, global is global
+(define (global-filledbox width dy dx height x y)
+ (string-append
+ "fp((0,0,0))\n"
+ "lw(0.1)\n"
+ "r("
+ (sk-numbers->string
+ (map global-mul-scale (list width dy dx height x y)))
+ ")\n"))
+
+(define (global-bezier l)
+ (let* ((c0 (car (list-tail l 3)))
+ (c123 (list-head l 3))
+ (start (control->list c0))
+ (control (apply append (map control->list c123))))
+ (string-append
+ "bs(" (sk-numbers->string (map global-mul-scale start)) ",0)\n"
+ "bc(" (sk-numbers->string (map global-mul-scale control)) ",2)\n")))
+
+
+(define (global-beziers l thick)
+ (let* (;;(burp (set! global-y (+ global-y (* 2 (cdar l)))))
+ (first
+ (list-tail l 4))
+ (second
+ (list-head l 4))
+ )
+ (string-append
+ "fp((0,0,0))\n"
+ "lw(0.1)\n"
+ "b()\n"
+ (global-bezier first)
+ (global-bezier second)
+ ;;"b_()\n"
+ )))
+
+
+;; alist containing fontname -> fontcommand assoc (both strings)
+(define font-alist '())
+(define font-count 0)
+(define current-font "")
+
+(define (fontify name-mag-pair exp)
+ (string-append (select-font name-mag-pair)
+ (if (string? exp) exp "")))
+
+(define (define-fonts x) "")
+
+(define (font-def x)
+"")
+
+
+(define (cached-fontname i)
+ "")
+
+(define (select-font name-mag-pair)
+ (set! global-font (car name-mag-pair))
+ "")
+
+(define (font-load-command name-mag command)
+ "")
+
+(define (beam width slope thick)
+ (let ((s (list
+ 'global-filledbox
+ width
+ (* slope width)
+ 0
+ thick
+ 'global-x
+ 'global-y)))
+ (set! global-s s))
+ "\n")
+
+(define (comment s)
+ (string-append "% " s))
+
+(define (bracket arch_angle arch_width arch_height height arch_thick thick)
+ (string-append
+ (numbers->string (list arch_angle arch_width arch_height height arch_thick thick)) " draw_bracket" ))
+
+(define (char i)
+ (set! global-s
+;; `(string-append "txt(" ,(number->string i) ",("
+;; (sk-numbers->string (list global-x global-y))
+ `(string-append
+ "fp((0,0,0))\n"
+ "le()\n"
+ "lw(0.1)\n"
+;; "Fn('" global-font "')\n"
+;; "Fn('Times-Roman')\n"
+ "Fn('TeX-feta20')\n"
+ "Fs(20)\n"
+ ;; chars > 128 don't work yet
+ "txt('" ,(ascii->string (modulo i 128)) "',("
+;; "char(" ,(number->string i) ",("
+ (sk-numbers->string (list (* global-scale global-x)
+ (* global-scale global-y)))
+ "))\n")))
+
+(define (hairpin thick width starth endh )
+ (string-append
+ (numbers->string (list width starth endh thick))
+ " draw_hairpin"))
+
+;; what the heck is this interface ?
+(define (dashed-slur thick dash l)
+ (string-append
+ (apply string-append (map control->string l))
+ (ly-number->string thick)
+ " [ "
+ (ly-number->string dash)
+ " "
+ (ly-number->string (* 10 thick)) ;UGH. 10 ?
+ " ] 0 draw_dashed_slur"))
+
+(define (dashed-line thick on off dx dy)
+ (string-append
+ (ly-number->string dx)
+ " "
+ (ly-number->string dy)
+ " "
+ (ly-number->string thick)
+ " [ "
+ (ly-number->string on)
+ " "
+ (ly-number->string off)
+ " ] 0 draw_dashed_line"))
+
+(define (repeat-slash wid slope thick)
+ (string-append (numbers->string (list wid slope thick))
+ " draw_repeat_slash"))
+
+(define (end-output)
+ "guidelayer('Guide Lines',1,0,0,1,(0,0,1))
+grid((0,0,20,20),0,(0,0,1),'Grid')\n")
+
+(define (experimental-on) "")
+
+(define (font-switch i)
+ "")
+
+(define (header-end)
+ "")
+
+(define (lily-def key val)
+ (if (equal? key "lilypondpaperoutputscale")
+ (set! global-scale (string->number val)))
+ "")
+
+
+(define (header creator generate)
+ (string-append
+ "##Sketch 1 2
+document()
+layout('A4',0)
+layer('Layer 1',1,1,0,0,(0,0,0))
+"))
+
+(define (invoke-char s i)
+ "")
+
+(define (invoke-dim1 s d)
+ (string-append
+ (ly-number->string (* d (/ 72.27 72))) " " s ))
+
+;; urg
+(define (placebox x y s)
+ (format (current-error-port) "placebox: ~S, ~S, ~S\n" x y s)
+ (set! global-x (+ x 0))
+ (set! global-y (+ y 100))
+ (let ((s (primitive-eval global-s)))
+ (set! global-s "\n")
+ s))
+
+(define (bezier-sandwich l thick)
+ (let ((s (list
+ 'global-beziers
+ 'global-list
+ thick)))
+ (set! global-s s)
+ (set! global-list l))
+ "\n")
+
+; TODO: use HEIGHT argument
+(define (start-line height)
+ "G()\n"
+ )
+
+;; r((520.305,0,0,98.0075,51.8863,10.089))
+;; width, 0, 0, height, x, y
+(define (filledbox breapth width depth height)
+ (let ((s (list
+ 'global-filledbox
+ (+ breapth width)
+ 0 0
+ (+ depth height)
+ `(- global-x ,breapth)
+ `(- global-y ,depth))))
+ (format (current-error-port) "filledbox: ~S\n" s)
+ (set! global-s s))
+ "\n")
+
+(define (stem x y z w) (filledbox x y z w))
+
+
+(define (stop-line)
+ "G_()\n")
+
+;; huh?
+(define (stop-last-line)
+ stop-line)
+
+(define (text s)
+ (set! global-s
+ `(string-append "txt('" ,s "',("
+ (sk-numbers->string (list global-x global-y))
+ "))\n")))
+
+
+(define (volta h w thick vert_start vert_end)
+ (string-append
+ (numbers->string (list h w thick (inexact->exact vert_start) (inexact->exact vert_end)))
+ " draw_volta"))
+
+(define (tuplet ht gap dx dy thick dir)
+ (string-append
+ (numbers->string (list ht gap dx dy thick (inexact->exact dir)))
+ " draw_tuplet"))
+
+
+(define (unknown)
+ "\n unknown\n")
+
+(define (ez-ball ch letter-col ball-col)
+ (string-append
+ " (" ch ") "
+ (numbers->string (list letter-col ball-col))
+ " /Helvetica-Bold " ;; ugh
+ " draw_ez_ball"))
+
+(define (define-origin a b c ) "")
+(define (no-origin) "")
+
projects / lilypond.git / commitdiff