From 9708492f34f3a862873cd718539459b40a3bc2f8 Mon Sep 17 00:00:00 2001
From: Jan Nieuwenhuizen <janneke@gnu.org>
Date: Mon, 14 Oct 2002 15:09:52 +0000
Subject: [PATCH] 	* scm/tex.scm: 	* scm/ps.scm: Cleanup and remove
 obsolete junk.

	* Documentation/user/internals.itely:
	* Documentation/user/refman.itely: Run texinfo-all-menus-update.
---
 ChangeLog   |   3 +
 scm/ps.scm  | 382 ++++++++++++++++++++++++----------------------------
 scm/tex.scm |  10 +-
 3 files changed, 179 insertions(+), 216 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 954d4ecbb5..356346077e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -12,6 +12,9 @@
 	
 2002-10-14  Jan Nieuwenhuizen  <janneke@gnu.org>
 
+	* scm/tex.scm: 
+	* scm/ps.scm: Cleanup and remove obsolete junk.
+
 	* Documentation/user/internals.itely:
 	* Documentation/user/refman.itely: Run texinfo-all-menus-update.
 
diff --git a/scm/ps.scm b/scm/ps.scm
index ce740eaaf1..c0989502fe 100644
--- a/scm/ps.scm
+++ b/scm/ps.scm
@@ -1,138 +1,86 @@
-;;; ps.scm -- implement Scheme output routines for PostScript
-;;;
-;;;  source file of the GNU LilyPond music typesetter
-;;; 
-;;; (c) 1998--2002 Jan Nieuwenhuizen <janneke@gnu.org>
-;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; ps.scm -- implement Scheme output routines for PostScript
+;;;;
+;;;;  source file of the GNU LilyPond music typesetter
+;;;; 
+;;;; (c) 1998--2002 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
 
 
+(debug-enable 'backtrace)
 
-(define-module
-  (scm ps)
 
-  )
+(define-module (scm ps))
+(define this-module (current-module))
 
-(define font-name-alist  '())
+(use-modules
+ (guile)
+ (lily))
 
-(define this-module (current-module))
 
-(debug-enable 'backtrace)
 
-(if (or (equal? (minor-version) "4.1")
-	(equal? (minor-version) "4")
-	(equal? (minor-version) "3.4"))
-    (define-public (ps-output-expression expr port)
-      (display (eval-in-module expr this-module) port))
+;;; Lily output interface --- cleanup and docme
 
-    (define-public (ps-output-expression expr port)
-      (display (eval expr this-module) port)))
 
- 
-(use-modules
- (guile)
- (lily)
-)
-
-
-
-;;;;;;;;
-;;;;;;;; DOCUMENT ME!
-;;;;;;;; 
-(define (tex-encoded-fontswitch name-mag)
-  (let* ((iname-mag (car name-mag))
-	 (ename-mag (cdr name-mag)))
-    (cons iname-mag
-	  (cons ename-mag
-		(string-append  "magfont"
-			  (string-encode-integer
-			   (hashq (car ename-mag) 1000000))
-			  "m"
-			  (string-encode-integer
-			   (inexact->exact (* 1000 (cdr ename-mag)))))))))
 
-(define (fontify name-mag-pair exp)
-  (string-append (select-font name-mag-pair)
-		 exp))
+;; Module entry
+(define-public (ps-output-expression expr port)
+  (display (eval expr this-module) port))
 
 
-(define (define-fonts internal-external-name-mag-pairs)
-  (set! font-name-alist (map tex-encoded-fontswitch
-			     internal-external-name-mag-pairs))
-  (apply string-append
-	 (map (lambda (x)
-		(font-load-command (car x) (cdr x)))
-	      (map cdr font-name-alist))))
+;; Global vars
 
 ;; alist containing fontname -> fontcommand assoc (both strings)
-(define font-alist '())
-(define font-count 0)
-(define current-font "")
-
-(define (select-font name-mag-pair)
-  (let*
-      (
-       (c (assoc name-mag-pair font-name-alist))
-       )
-
-    (if (eq? c #f)
-	(begin
-	  (display "FAILED\n")
-	  (display (object-type (car name-mag-pair)))
-	  (display (object-type (caaar font-name-alist)))
-
-	  (ly:warn (string-append
-		    "Programming error: No such font known "
-		    (car name-mag-pair) " "
-		    (ly:number->string (cdr name-mag-pair))
-		    ))
-	  
-	  "") ; issue no command	  
-	(string-append " " (cddr c) " "))
-    ))
-
-(define (font-load-command name-mag command)
-  (string-append
-   "/" command
-   " { /"
-   (capitalize-font-name (car name-mag))
-   " findfont "
-   "20 " (ly:number->string (cdr name-mag)) " mul "
-   "output-scale div scalefont setfont } bind def "
-   "\n"))
-
-;; Ugh, the Bluesky type1 fonts for computer modern use capitalized 
-;; postscript font names.
-(define (capitalize-font-name name)
-  (if (equal? (substring name 0 2) "cm")
-      (string-upcase name)
-      name))
+(define font-name-alist '())
 
+
+;; Interface functions
 (define (beam width slope thick)
   (string-append
    (numbers->string (list slope width thick)) " draw_beam" ))
 
-(define (comment s)
-  (string-append "% " s "\n"))
+;; two beziers with round endings
+(define (bezier-bow l thick)
+  
+  (define (bezier-ending z0 z1 z2)
+    (let ((x0 (car z0))
+	  (y0 (cdr z0))
+	  (x1 (car z1))
+	  (y1 (cdr z1))
+	  (x2 (car z2))
+	  (y2 (cdr z2)))
+      (string-append
+       " "
+       (numbers->string
+	(list x0 y0
+	      (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
+       " draw_dot")))
+  
+  (string-append 
+   (apply string-append (map number-pair->string l))
+   (ly:number->string thick)
+   " draw_bezier_sandwich "
+   (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
+   (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
+
+;; two beziers
+(define (bezier-sandwich l thick)
+  (string-append 
+   (apply string-append (map number-pair->string l))
+   (ly:number->string thick)
+   " draw_bezier_sandwich "))
 
 (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" ))
+   (numbers->string
+    (list arch_angle arch_width arch_height height arch_thick thick))
+   " draw_bracket"))
 
 (define (char i)
-  (invoke-char " show" i))
-
-
-
-;; what the heck is this interface ?
-(define (dashed-slur thick dash l)
   (string-append 
-   (apply string-append (map number-pair->string l)) 
-   (ly:number->string thick) 
-   " [ "
-   (ly:number->string dash)
-   " "
-   (ly:number->string (* 10 thick))	;UGH.  10 ?
-   " ] 0 draw_dashed_slur"))
+   "(\\" (inexact->string i 8) ") show " ))
+
+(define (comment s)
+  (string-append "% " s "\n"))
 
 (define (dashed-line thick on off dx dy)
   (string-append 
@@ -147,8 +95,64 @@
    (ly:number->string off)
    " ] 0 draw_dashed_line"))
 
-(define (draw-line thick x1 y1 x2 y2)
+;; what the heck is this interface ?
+(define (dashed-slur thick dash l)
+  (string-append 
+   (apply string-append (map number-pair->string l)) 
+   (ly:number->string thick) 
+   " [ "
+   (ly:number->string dash)
+   " "
+   ;;UGH.  10 ?
+   (ly:number->string (* 10 thick))
+   " ] 0 draw_dashed_slur"))
 
+(define (define-fonts internal-external-name-mag-pairs)
+  
+  (define (font-load-command name-mag command)
+    
+    (define (possibly-capitalize-font-name name)
+      (if (equal? (substring name 0 2) "cm")
+	  (string-upcase name)
+	  name))
+    
+    (string-append
+     "/" command
+     " { /"
+     ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized 
+     ;; postscript font names.
+     (possibly-capitalize-font-name (car name-mag))
+     " findfont "
+     "20 " (ly:number->string (cdr name-mag)) " mul "
+     "output-scale div scalefont setfont } bind def "
+     "\n"))
+
+  (define (ps-encoded-fontswitch name-mag-pair)
+    (let* ((key (car name-mag-pair))
+	   (value (cdr name-mag-pair)))
+      (cons key
+	    (cons value
+		  (string-append "lilyfont"
+				 (car value)
+				 "-"
+				 (number->string (cdr value)))))))
+      
+  (set! font-name-alist (map ps-encoded-fontswitch
+			     internal-external-name-mag-pairs))
+
+  (apply string-append
+	 (map (lambda (x) (font-load-command (car x) (cdr x)))
+	      (map cdr font-name-alist))))
+
+(define (define-origin file line col) "")
+
+(define (dot x y radius)
+  (string-append
+   " "
+   (numbers->string
+    (list x y radius)) " draw_dot"))
+
+(define (draw-line thick x1 y1 x2 y2)
   (string-append 
   "	1 setlinecap
 	1 setlinejoin "
@@ -161,42 +165,46 @@
    (ly:number->string x2)
    " "
    (ly:number->string y2)
-   " lineto stroke"
-
-  ))
-
-(define (repeat-slash wid slope thick)
-  (string-append (numbers->string (list wid slope thick))
-		 " draw_repeat_slash"))
+   " lineto stroke"))
 
 (define (end-output)
   "\nend-lilypond-output\n")
 
-(define (experimental-on) "")
+(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 (filledbox breapth width depth height) 
   (string-append (numbers->string (list breapth width depth height))
 		 " draw_box" ))
 
-(define (roundfilledbox x y width height blotdiam)
-   (string-append " "
-      (numbers->string
-         (list x y width height blotdiam)) " draw_round_box"))
+(define (fontify name-mag-pair exp)
 
-(define (dot x y radius)
-    (string-append " "
-     (numbers->string
-      (list x y radius)) " draw_dot"))
+  (define (select-font name-mag-pair)
+    (let* ((c (assoc name-mag-pair font-name-alist)))
+      (if (eq? c #f)
+	  (begin
+	    (display "FAILED\n")
+	    (display (object-type (car name-mag-pair)))
+	    (display (object-type (caaar font-name-alist)))
+	    (ly:warn (string-append
+		      "Programming error: No such font known "
+		      (car name-mag-pair) " "
+		      (ly:number->string (cdr name-mag-pair))))
+	    
+	    ;; Upon error, issue no command
+	    "")
+	  (string-append " " (cddr c) " "))))
+  
+  (string-append (select-font name-mag-pair) exp))
 
-;; obsolete?
-(define (font-def i s)
+(define (header creator generate) 
   (string-append
-   "\n/" (font i) " {/" 
-   (substring s 0 (- (string-length s) 4))
-   " findfont 12 scalefont setfont} bind def \n"))
-
-(define (font-switch i)
-  (string-append (font i) " "))
+   "%!PS-Adobe-3.0\n"
+   "%%Creator: " creator generate "\n"))
 
 (define (header-end)
   (string-append
@@ -205,99 +213,59 @@
    " {exch pop //systemdict /run get exec} "
    (ly:gulp-file "music-drawing-routines.ps")
    "{ exch pop //systemdict /run get exec } "
-
-;; ps-testing wreaks havoc when used with lilypond-book.
-;;   (if (defined? 'ps-testing) "\n /testing true def" "")
-
-
+   ;; ps-testing wreaks havoc when used with lilypond-book.
+   ;;  -- is this still true with new modules system?
+   ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
    ;;   "\n /testing true def"
    ))
 
 (define (lily-def key val)
+  (let ((prefix "lilypondpaper"))
+    (if (string=?
+	 (substring key 0 (min (string-length prefix) (string-length key)))
+	 prefix)
+	(string-append "/" key " {" val "} bind def\n")
+	(string-append "/" key " (" val ") def\n"))))
 
-  (if (string=? (substring key 0 (min (string-length "lilypondpaper") (string-length key))) "lilypondpaper")
-      (string-append "/" key " {" val "} bind def\n")
-      (string-append "/" key " (" val ") def\n")
-      )
-  )
-
-(define (header creator generate) 
-  (string-append
-   "%!PS-Adobe-3.0\n"
-   "%%Creator: " creator generate "\n"))
-
-(define (invoke-char s i)
-  (string-append 
-   "(\\" (inexact->string i 8) ") " s " " ))
-
-
+(define (no-origin) "")
+  
 (define (placebox x y s) 
   (string-append 
    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 
-;; two beziers
-(define (bezier-sandwich l thick)
-  (string-append 
-   (apply string-append (map number-pair->string l))
-   (ly:number->string thick)
-   " draw_bezier_sandwich "))
-
-;; two beziers with round endings
-(define (bezier-bow l thick)
-  (string-append 
-   (apply string-append (map number-pair->string l))
-   (ly:number->string thick)
-   " draw_bezier_sandwich "
-   (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
-   (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
+(define (repeat-slash wid slope thick)
+  (string-append
+   (numbers->string (list wid slope thick))
+   " draw_repeat_slash"))
 
-;; two beziers with round endings
-(define (bezier-ending z0 z1 z2)
-  (let ((x0 (car z0))
-	(y0 (cdr z0))
-	(x1 (car z1))
-	(y1 (cdr z1))
-	(x2 (car z2))
-	(y2 (cdr z2)))
-    (string-append " "
-     (numbers->string
-      (list x0 y0
-	    (/ (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2)))) 2)))
-     " draw_dot")))
-
-					; TODO: use HEIGHT argument
+(define (roundfilledbox x y width height blotdiam)
+   (string-append
+    " "
+    (numbers->string
+     (list x y width height blotdiam)) " draw_round_box"))
 
+;; TODO: use HEIGHT argument
 (define (start-system width height)
-  (string-append "\n" (ly:number->string height)
-		 " start-system\n"
-		 "{\n"
-		 "set-ps-scale-to-lily-scale"))
+  (string-append
+   "\n" (ly:number->string height)
+   " start-system\n"
+   "{\n"
+   "set-ps-scale-to-lily-scale"))
 
 (define (stem breapth width depth height) 
-  (string-append (numbers->string (list breapth width depth height))
-		 " draw_box" ))
-
-(define (stop-system)
-  "}\nstop-system\n")
+  (string-append
+   (numbers->string (list breapth width depth height))
+   " draw_box" ))
 
 (define (stop-last-system)
+  (stop-system))
+
+(define (stop-system)
   "}\nstop-system\n")
 
 (define (text s)
-  (string-append "(" s ") show  "))
-
+  (string-append "(" s ") show "))
 
 (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) "")
-  
-  
diff --git a/scm/tex.scm b/scm/tex.scm
index 1e3a9bb253..bab65d7a64 100644
--- a/scm/tex.scm
+++ b/scm/tex.scm
@@ -169,14 +169,6 @@
 (define (repeat-slash w a t)
   (embedded-ps (list 'repeat-slash  w a t)))
 
-(define (font-switch i)
-  (string-append
-   "\\" (font i) "\n"))
-
-(define (font-def i s)
-  (string-append
-   "\\font" (font-switch i) "=" s "\n"))
-
 (define (header-end)
   (string-append
    "\\def\\scaletounit{ "
@@ -312,7 +304,7 @@
       "")
   )
 
-					; no-origin not yet supported by Xdvi
+;; no-origin not yet supported by Xdvi
 (define (no-origin) "")
 
 (define my-eval-in-module eval)
-- 
2.39.5