From 372c3944d6b441f7b4a8609d42c6e2bdd71d65c3 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Fri, 9 Nov 2001 22:10:28 +0100 Subject: [PATCH] patch::: 1.5.22.jcn1 1.5.22.jcn1 =========== * Resurrected experimental sketch output, now with dispatch. 1.5.22 ====== --- CHANGES | 7 ++ VERSION | 2 +- input/test/sketch.ly | 5 +- scm/lily.scm | 3 +- scm/sketch.scm | 290 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 303 insertions(+), 4 deletions(-) diff --git a/CHANGES b/CHANGES index a12ec801ca..310347fd95 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,10 @@ +1.5.22.jcn1 +=========== + +* Resurrected experimental sketch output, now with dispatch. + +1.5.22 +====== 1.5.21.hwn1 =========== diff --git a/VERSION b/VERSION index 36100a3a88..ff8924f481 100644 --- a/VERSION +++ b/VERSION @@ -2,7 +2,7 @@ PACKAGE_NAME=LilyPond MAJOR_VERSION=1 MINOR_VERSION=5 PATCH_LEVEL=22 -MY_PATCH_LEVEL= +MY_PATCH_LEVEL=jcn1 # use the above to send patches: MY_PATCH_LEVEL is always empty for a # released version. diff --git a/input/test/sketch.ly b/input/test/sketch.ly index fefc6d0f34..ffe66521e5 100644 --- a/input/test/sketch.ly +++ b/input/test/sketch.ly @@ -3,8 +3,9 @@ texidoc="sketch output supported features" } \score { \notes\relative c''' { - - \time 3/4 a4( a a a )a +% doesn't work yet +% \time 3/4 + a4( a a a )a \stemDown a,8( b c )d \stemUp diff --git a/scm/lily.scm b/scm/lily.scm index d5aa43e429..8922fef0ea 100644 --- a/scm/lily.scm +++ b/scm/lily.scm @@ -119,11 +119,11 @@ - (use-modules (scm tex) (scm ps) (scm pysk) (scm ascii-script) + (scm sketch) ) (define output-alist @@ -133,6 +133,7 @@ ("scm" . ,write) ("as" . ,as-output-expression) ("pysk" . ,pysk-output-expression) + ("sketch" . ,sketch-output-expression) )) diff --git a/scm/sketch.scm b/scm/sketch.scm index 8b13789179..c5417abeab 100644 --- a/scm/sketch.scm +++ b/scm/sketch.scm @@ -1 +1,291 @@ +;;; sketch.scm -- implement Scheme output routines for Sketch +;;; +;;; source file of the GNU LilyPond music typesetter +;;; +;;; (c) 1998--2001 Jan Nieuwenhuizen +;;; Han-Wen Nienhuys + + +;; als in: + +;; def dispats (out,x,y,expr): +;; (symbol, rest) = expr +;; if symbol == 'placebox': +;; (dx,dy,expr) = rest +;; dispats (out, x + dx, y + dy, expr) +;; # hier wordt (X+DX) dus eerder gedaan dan dispats van EXPR. +;; # er zijn geen "globale" variabelen. +;; elif symbol == 'char': +;; out.write ('moveto( %f %f); char(%d)' % (x,y,rest)) + + +;; (define (dispatch x y expr) +;; (let ((keyword (car expr))) +;; (cond +;; ((eq? keyword 'placebox) +;; (dispatch (+ x (cadr expr)) (+ y (caddr expr) (cadddr expr))) + +;; [etc.] +;; )) + + + +(define-module (scm sketch) + :export (sketch-output-expression) + :no-backtrace) + +(define this-module (current-module)) + +(define (sketch-output-expression expr port) + (display (dispatch expr) port)) + +(use-modules + (guile) + (guile-user)) + +(use-modules (ice-9 format)) + + +(define (dispatch expr) + (let ((keyword (car expr))) + (cond + ((eq? keyword 'placebox) + (dispatch-x-y (cadr expr) (+ 150 (caddr expr)) (cadddr expr))) + (else + (apply (eval keyword this-module) (cdr expr)))))) + +(define (dispatch-x-y x y expr) + (apply (eval (car expr) this-module) (append (list x y) (cdr expr)))) + + + + +(define (ascii->string i) (make-string 1 (integer->char i))) + +(define (control->list x y c) + (list (+ x (car c)) (+ y (cdr c)))) + +(define (control-flip-y c) + (cons (car c) (* -1 (cdr c)))) + +;;; urg. +(define (sketch-numbers->string l) + (string-append + (number->string (car l)) + (if (null? (cdr l)) + "" + (string-append "," (sketch-numbers->string (cdr l)))))) + +(define font "") +(define output-scale 1.0) +(define (mul-scale x) (* output-scale x)) + +(define (sketch-filled-rectangle width dy dx height x y) + (string-append + "fp((0,0,0))\n" + "lw(0.1)\n" + "r(" + (sketch-numbers->string (map mul-scale (list width dy dx height x y))) + ")\n")) + +(define (sketch-bezier x y l) + (let* ((c0 (car (list-tail l 3))) + (c123 (list-head l 3)) + (start (control->list x y c0)) + (control (apply append + (map (lambda (c) (control->list x y c)) c123)))) + (string-append + "bs(" (sketch-numbers->string (map mul-scale start)) ",0)\n" + "bc(" (sketch-numbers->string (map mul-scale control)) ",2)\n"))) + + +(define (sketch-beziers x y l thick) + (let* ((first (list-tail l 4)) + (second (list-head l 4))) + (string-append + "fp((0,0,0))\n" + "lw(0.1)\n" + "b()\n" + (sketch-bezier x y first) + (sketch-bezier x y second)))) + + +;; alist containing fontname -> fontcommand assoc (both strings) +(define font-alist '()) +(define font-count 0) +(define current-font "") + +(define (fontify x y name-mag-pair exp) + (string-append (select-font name-mag-pair) + (apply (eval (car exp) this-module) + (append (list x y) (cdr exp))))) +;; (if (string? exp) exp ""))) + +(define (define-fonts x) "") + +(define (font-def x) +"") + + +(define (cached-fontname i) + "") + +(define (select-font name-mag-pair) + (set! font (car name-mag-pair)) + "") + +(define (font-load-command name-mag command) + "") + +(define (beam x y width slope thick) + (apply sketch-filled-rectangle + (map mul-scale + (list width (* slope width) 0 thick x y)))) + +(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 x y i) + (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 + (format #f "txt('\\~o',(" (modulo i 128)) + ;; "char(" ,(number->string i) ",(" + (sketch-numbers->string (map mul-scale (list x y))) + "))\n")) + +(define (hairpin x y 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") + ;; ugr + (set! output-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 )) + +(define (bezier-sandwich x y l thick) + (apply + sketch-beziers (list x y (primitive-eval l) thick))) + +; 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 x y breapth width depth height) + (apply sketch-filled-rectangle + (list + (+ breapth width) 0 0 (+ depth height) (- x breapth) (- y depth)))) + +(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 x y s) + (string-append "txt('" s "',(" (sketch-numbers->string + (map mul-scale (list x y))) "))\n")) + + +(define (volta x y 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 x y 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) "") + + -- 2.39.5