home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / b116_1 / jacal / unparse < prev    next >
Text File  |  1993-11-26  |  14KB  |  442 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1992, 1993 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; a LINE is a list of column positions and strings or characters
  6. ;;; which appear there on one horizontal line.
  7.  
  8. ;;; a BOX is a list of pairs of line-numbers and LINEs.
  9. ;;; a PBOX consists of a BP (binding power) and a list of boxes.
  10.  
  11. ;;; a TEMPLATE is an HBOX.  An HBOX is a list of strings, symbols and
  12. ;;; VBOXes.  A VBOX is a list of pairs of a row position and an HBOX
  13. ;;; or a list of a character.
  14.  
  15. ;;; A number of the form #dNBBB in a template is replaced with the BOX
  16. ;;; for argument N.  If the #dNBBB appears in a HBOX then it is glued
  17. ;;; horizontally to the other elements in the HBOX.  If the #dNBBB
  18. ;;; appears in a VBOX then it is glued vertically to the other
  19. ;;; elements in the VBOX.  BBB denotes the maximum binding power of
  20. ;;; the argument.  If the binding power of the argument is less than
  21. ;;; BBB, parenthesis will be added according to TEMPLATE:PARENTHESIS.
  22.  
  23. ;;; Characters in HBOXes are expanded horizontally to fill any empty
  24. ;;; space in their line.  A list of a character VBOX is expanded
  25. ;;; vertically to fill any empty space in its containing HBOX.
  26.  
  27. ;;; The symbol 'BREAK will break the line if there is not enough
  28. ;;; horizontal room remaining.
  29.  
  30. (require 'rev3-procedures)
  31. (require 'common-list-functions)
  32.  
  33. ;;; TEXT-WIDTH
  34.  
  35. (define text-width string-length)
  36.  
  37. ;;; return the position of symbol #dNBBB
  38.  
  39. (define (arg-pos num)
  40.   (quotient num 1000))
  41.  
  42. (define (arg-bp num)
  43.   (modulo num 1000))
  44.  
  45. (define make-template cons)
  46. (define template-bp car)
  47. (define template-hbox cdr)
  48.  
  49. ;;; Utility routines for dealing with BOX
  50. ;;; BOX is a list of (line-number-referred-to-center . LINE)
  51. ;;; LINE is a list of POSITIONs and STRINGs.
  52. ;(require 'record)
  53. ;(define pbox-type (make-record-type "box" '(bp lines)))
  54. ;(define make-pbox (record-constructor pbox-type))
  55. ;(define pbox-bp (record-accessor pbox-type 'bp))
  56. ;(define pbox-lines (record-accessor pbox-type 'lines))
  57.  
  58. (define make-pbox cons)
  59. (define pbox-bp car)
  60. (define pbox-lines cdr)
  61.  
  62. (define top-edge caar)
  63.  
  64. (define left-edge cadar)
  65.  
  66. (define (bottom-edge box)
  67.   (caar (last-pair box)))
  68.  
  69. (define (right-edge box)
  70.   (define redge 0)
  71.   (for-each
  72.    (lambda (line)
  73. ;;;     (define re 0)
  74. ;;;     (for-each (lambda (x)
  75. ;;;         (cond ((number? x) (set! re x))
  76. ;;;               ((string? x)
  77. ;;;            (set! re (+ (text-width x) re)))))
  78. ;;;           (cdr line))
  79. ;;;     (set! redge (max re redge))
  80.      (if (not (null? (cdr line)))
  81.      (let ((end (last line 2)))
  82.        (set! redge (max redge (+ (car end)
  83.                      (if (string? (cadr end))
  84.                      (text-width (cadr end))
  85.                      0)))))))
  86.    box)
  87.   redge)
  88.  
  89. (define (shift-numbers! lst inc)
  90.   (cond ((null? lst))
  91.     (else (set-car! lst (+ inc (car lst)))
  92.           (shift-numbers! (cddr lst) inc))))
  93.  
  94. ;;; routines for actually writing the 2d formated output to a port.
  95. ;;; These can be replaced with code which does cursor positioning.
  96.  
  97. (define (flush-blanks box)
  98.   (cond ((null? box) box)
  99.     ((> (top-edge box) (+ 1 lte))
  100.      (newline)
  101.      (set! lte (+ -1 (top-edge box)))
  102.      (flush-blanks box))
  103.     ((null? (cdar box))
  104.      (newline)
  105.      (set! lte (top-edge box))
  106.      (flush-blanks (cdr box)))
  107.     (else box)))
  108.  
  109. (define (chunk-height box)
  110.   (let ((base lte))
  111.     (do ((b box (cdr b))
  112.      (lte base (top-edge b)))
  113.     ((or (null? b) (null? (cdar b)) (not (= (+ 1 lte) (top-edge b))))
  114.      (if (zero? (- lte base)) 1 (- lte base)))
  115.       (set! lte (top-edge b)))))
  116.  
  117. (define (display-box box)
  118.   (define h (get-page-height))
  119.   (set! box (flush-blanks box))
  120.   (set! lte (+ -1 (top-edge box)))
  121.   (let loop ((box box))
  122.     (cond ((null? box) box)
  123.       ((begin (set! box (flush-blanks box))
  124.           (< (+ linum (chunk-height box)) h))
  125.        (loop (display-chunk box)))
  126.       ((or (zero? h) (zero? linum)) (loop (display-chunk box)))
  127.       ((do-more)
  128.        (set! linum 0)
  129.        (loop (display-chunk box)))
  130.       (else #f))))
  131.  
  132. (define (display-chunk box)
  133.   (do ((b box (cdr b)))
  134.       ((or (null? b) (not (= (+ 1 lte) (top-edge b))) (null? (cdar b)))
  135. ;;;       (print (+ 1 lte) (and (not (null? b)) (top-edge b)) linum)
  136.        b)
  137.     (display-line 0 #\  (cdar b))
  138.     (if (not (null? (cdr b))) (newline))
  139.     (set! lte (top-edge b))
  140.     (set! linum (+ 1 linum))
  141.     (and (null? (cdar b)) (not (zero? (get-page-height)))
  142.      (not (do-more)) (set! b '(())))))
  143.  
  144. (define (display-line hpos fillchr line)
  145.   (cond ((null? line) hpos)
  146.     ((string? (cadr line))
  147.      (display (make-string (- (car line) hpos) fillchr))
  148.      (display (cadr line))
  149.      (display-line (+ (car line) (text-width (cadr line)))
  150.                fillchr
  151.                (cddr line)))
  152.     ((char? (cadr line))
  153.      (display (make-string (- (car line) hpos) fillchr))
  154.      (display-line (car line)
  155.                (cadr line)
  156.                (cddr line)))
  157.     (else (error "DISPLAY-LINE: error" line))))
  158.  
  159. ;;; Glue 2 boxes together horizontally, with the RIGHTBOX moved
  160. ;;; POSINC to the right
  161.  
  162. (define (hglue-lines! leftbox posinc rightbox)
  163.   (cond ((null? rightbox) leftbox)
  164.     ((null? leftbox) '())
  165.     ((char? (car rightbox))
  166.      (cons (nconc (car leftbox) (list posinc (string (car rightbox))))
  167.            (hglue-lines! (cdr leftbox) posinc rightbox)))
  168.     ((< (top-edge leftbox) (top-edge rightbox))
  169.      (cons (car leftbox)
  170.            (hglue-lines! (cdr leftbox) posinc rightbox)))
  171.     (else                ;line up
  172.      (if (not (zero? posinc)) (shift-numbers! (cdar rightbox) posinc))
  173.      (cons (nconc (car leftbox) (cdar rightbox))
  174.            (hglue-lines! (cdr leftbox) posinc (cdr rightbox))))))
  175.  
  176. (define (hglue boxes hroom)
  177.   (let ((arights (list (cond ((null? boxes) 0)
  178.                  ((null? (car boxes)) 0)
  179.                  ((char? (car (car boxes))) 1)
  180.                  (else (right-edge (car boxes))))))
  181.     (right -1) (top 0) (bottom 0))
  182.     (do ((boxes boxes (cdr boxes))
  183.      (rights
  184.       arights
  185.       (begin (set-cdr!
  186.           rights
  187.           (if (null? (cdr boxes)) '()
  188.               (list (cond ((null? (cadr boxes)) 0)
  189.                   ((char? (caadr boxes)) 1)
  190.                   (else (right-edge (cadr boxes)))))))
  191.          (cdr rights)))
  192.      (redge 0 (+ redge (car rights))))
  193.     ((or (null? boxes) (and (positive? right) (> redge hroom)))
  194.      (if (<= redge hroom) (set! right -2)))
  195.       (cond ((equal? (car boxes) '((0 0 break)))
  196.          (set! right redge))
  197.         ((char? (caar boxes)))
  198.         (else (set! bottom (max bottom (bottom-edge (car boxes))))
  199.           (set! top (min top (top-edge (car boxes)))))))
  200.     (do ((boxes boxes (cdr boxes))
  201.      (rights arights (cdr rights))
  202.      (redge 0 (+ redge (car rights)))
  203.      (leftbox
  204.       (do ((i (+ -1 bottom) (+ -1 i))
  205.            (ans (list (list bottom)) (cons (list i) ans)))
  206.           ((< i top) ans))
  207.       (cond
  208.        ((equal? (car boxes) '((0 0 break)))
  209.         (cond ((= (+ redge (car rights)) right)
  210.            (set! arights #f)
  211.            (vformat! '((0 #d0000) (2 #d1000))
  212.                  (list (make-pbox 200 (list leftbox))
  213.                    (make-pbox 200 (cdr boxes)))
  214.                  #f hroom))
  215.           (else leftbox)))
  216.        (else (hglue-lines! leftbox redge (car boxes))))))
  217.     ((or (not arights) (null? boxes)) leftbox))))
  218.  
  219. ;;; Routines to format BOX from TEMPLATEs.
  220.  
  221. ;;; HFORMAT returns a list of boxes which need to be HGLUEd together
  222. ;;; into a single box.
  223.  
  224. (define (hformat hbox args tps hroom)
  225.   (if (null? hbox) '()
  226.       (let ((item (car hbox)) (hr (- hroom (quotient hroom 20))))
  227.     (cond
  228.      ((number? item)
  229.       (let ((argnum (arg-pos item)))
  230.         (if (> (length args) argnum)
  231.         (let ((arg (list-ref args argnum)))
  232.           (if (<= (arg-bp item) (pbox-bp arg))
  233.               (nconc (pbox-lines arg)
  234.                  (hformat (cdr hbox) args tps hroom))
  235.               (nconc
  236.                (hformat
  237.             (template-hbox (cdr (assq 'template:parenthesis tps)))
  238.             (list '() arg) tps hroom)
  239.                (hformat (cdr hbox) args tps hroom))))
  240.         (hformat (cdr hbox) args tps hroom))))
  241.      ((pair? item)
  242.       (cons (vformat! item args tps hr)
  243.         (hformat (cdr hbox) args tps hroom)))
  244.      ((vector? item)
  245.       (let ((vt (vector-ref item 0))
  246.         (vl (cdr (vector->list item))))
  247.         (cond ((<= (length args) (arg-pos (find-if number? vl)))
  248.            (hformat (cdr hbox) args tps hroom))
  249.           ((eq? 'REST vt)
  250.            (nconc (hformat vl args tps hroom)
  251.               (hformat hbox (cdr args) tps (- hroom hr))))
  252.           ((eq? 'OPTIONAL vt)
  253.            (nconc (hformat vl args tps hroom)
  254.               (hformat (cdr hbox) args tps hroom)))
  255.           (else (error "HFORMAT: unknown format" item)))))
  256.      (else (cons (list (list 0 0 item))
  257.              (hformat (cdr hbox) args tps hroom)))))))
  258.  
  259. (define (vformat! vbox args tps hroom)
  260.   (if (char? (car vbox))
  261.       vbox
  262.       (let* ((boxes (map (lambda (hbox)
  263.                (hglue (hformat (cdr hbox) args tps hroom)
  264.                   hroom))
  265.              vbox))
  266.          (rights (map right-edge boxes))
  267.          (mostright (apply max rights)))
  268.     (for-each
  269.      (lambda (box right)
  270.        (for-each
  271.         (lambda (line)
  272.           (cond ((null? (cdr line)))
  273.             ((and (char? (caddr line)) (null? (cdddr line)))
  274.              ;;terminate rubber line.
  275.              (nconc line (list mostright #\ )))
  276.             (else        ;center justify line.
  277.              (let ((lst (cdr line))
  278.                (inc (quotient (- mostright right) 2)))
  279.                (set-car! lst (+ inc (car lst)))
  280.                (shift-numbers! (cddr lst) inc)))))
  281.         box))
  282.      boxes
  283.      rights)
  284.     (vrenumber! vbox boxes)
  285.     (apply nconc boxes))))
  286.  
  287. ;;; the trick here is to make line 0 of hbox 0 still be line 0.  Push
  288. ;;; everything else up or down to make that happen.
  289. ;;; Here, vbox is used only for its hbox numbers.
  290. (define (vrenumber! vbox boxes)
  291.   (cond ((null? vbox) 0)
  292.     ((negative? (caar vbox))
  293.      (let ((topinc (+ (- (caar vbox)
  294.                  (if (null? (cdr vbox)) 0 (caadr vbox)))
  295.               (- (vrenumber! (cdr vbox) (cdr boxes))
  296.                  (bottom-edge (car boxes))))))
  297.        (or (zero? topinc)
  298.            (for-each
  299.         (lambda (line)
  300.           (set-car! line (+ (car line) topinc)))
  301.         (car boxes))))
  302.      (top-edge (car boxes)))
  303.     (else
  304.      (or (zero? (caar vbox))
  305.          (for-each            ;space down if no hbox 0
  306.           (lambda (line)
  307.         (set-car! line (+ (car line) (caar vbox))))
  308.           (car boxes)))
  309.      (let ((topinc (bottom-edge (car boxes)))
  310.            (lastnum (caar vbox)))
  311.        (for-each
  312.         (lambda (hbox box)
  313.           (set! topinc (+ (- (car hbox) lastnum)
  314.                   (- topinc (top-edge box))))
  315.           (set! lastnum (car hbox))
  316.           (for-each
  317.            (lambda (line)
  318.          (set-car! line (+ (car line) topinc)))
  319.            box)
  320.           (set! topinc (bottom-edge box)))
  321.         (cdr vbox)
  322.         (cdr boxes)))
  323.      (top-edge (car boxes)))))
  324.  
  325. ;;; Driver for 2d output
  326.  
  327. (define (inprint exp grm)
  328.   (tprint exp (grammar-write-tab grm)))
  329.  
  330. (define linum 0)
  331. (define lte 0)
  332. (define (tprint exp tps)
  333.   (define owidth (get-page-width))
  334.   (if (zero? owidth) (set! owidth 99999)) ;essentially infinite
  335.   (display-box (hglue (pbox-lines (unparse exp tps owidth)) owidth)))
  336.  
  337. (define (unparse exp tps hroom)
  338.   (cond ((symbol? exp)
  339.      (make-pbox 200 (list (list (list 0 0 (symbol->string exp))))))
  340.     ((number? exp)
  341.      (make-pbox 200 (list (list (list 0 0 (number->string exp))))))
  342.     ((list? exp)
  343.      (let* ((p (assq (car exp) tps)))
  344.        (unparse1 (if p (cdr p) (cdr (assq 'TEMPLATE:DEFAULT tps)))
  345.              exp tps hroom)))
  346.     ((not (vector? exp))
  347.      (slib:error 'UNPARSE 'not-s-expression exp))
  348.     ((zero? (vector-length exp))    ;this special case should be eliminated
  349.      (make-pbox 200 (list (list (list 0 0 "[]")))))
  350.     ((and (vector? (vector-ref exp 0))
  351.           (assq 'TEMPLATE:MATRIX tps)
  352.           (let ((len (vector-length (vector-ref exp 0))))
  353.         (every (lambda (r) (and (vector? r) (= (vector-length r) len)))
  354.                (cdr (vector->list exp)))))
  355.      (let ((hr (quotient hroom (vector-length exp)))
  356.            (template (cdr (assq 'TEMPLATE:MATRIX tps))))
  357.        (make-pbox
  358.         (template-bp template)
  359.         (hformat
  360.          (template-hbox template)
  361.          (map (lambda (obj)
  362.             (unparse1 (rubber-vbox (length obj)) obj tps hr))
  363.           ;transpose of exp
  364.           (apply map list (map vector->list
  365.                        (vector->list exp))))
  366.          tps hroom))))
  367.     (else (unparse1 (cdr (assq 'TEMPLATE:BUNCH tps))
  368.             (vector->list exp) tps hroom))))
  369.  
  370. (define (unparse1 template exp tps hroom)
  371.   (define hr (- hroom (quotient hroom 20)))
  372.   (make-pbox (template-bp template)
  373.          (hformat (template-hbox template)
  374.               (map (lambda (exp)
  375.                  (unparse exp tps hr))
  376.                exp)
  377.               tps hroom)))
  378.  
  379. (define (rubber-vbox len)
  380.   (make-template 200 (list (rubvbox (- 1 len) len))))
  381.  
  382. (define (rubvbox i len)
  383.   (if (>= i len) '()
  384.       (cons (list i (+ (* 1000 (quotient (+ i len) 2)) 10))
  385.         (rubvbox (+ i 2) len))))
  386.  
  387. ;;;; Test code
  388. ;;; To test, load this and English.scm.  Do (test2d tps:2d).
  389.  
  390. (define (test2d tps)
  391.   (for-each
  392.    (lambda (b) (tprint b tps) (newline))
  393.    '(
  394.      (+ (* 3 a b) (* 2 (^ a 2) b) c (* d e))
  395.      (sum (* (rapply a i) (^ x (- i 2))) i 0 inf)
  396.      (= %gamma (limit (sum (- (over 1 n) (log m)) n 1 m) m inf))
  397.      (^ (- (over 1 (^ (+ y x) 4)) (over 3 (^ (+ y x) 3))) 2)
  398.      (^ x (over (+ (^ a 2) 1) a))
  399.      (+ (- (over 2 (+ x 2)) (over 2 (+ x 1)))
  400.     (over 1 (^ (+ x 1) 2)))
  401.      (over (* (+ (^ x 2) (* 2 x) 1) (- y 1))
  402.        (* 36 (+ y 1)))
  403.      (+ (* (^ %e (f x)) ((over (^ d 2) (^ dx 2)) (f x)))
  404.     (* (^ %e (f x)) (^ ((over d dx) (f x)) 2)))
  405.      (+ (integrate (f x) x a b) x)
  406.      (integrate (^ e (^ x 2)) x)
  407.      (limit (^ (f x) (g (+ x 1))) x 0 minus)
  408.      (+ (over y (^ (box x) 2)) x)
  409.      (over (prod (^ (+ (^ x i) 1) (/ 5 2)) i 1 inf)
  410.        (+ (^ x 2) 1))
  411.      (over 1 (+ 4 (over 1 (+ 3 (over 1 42)))))
  412.      (over (* (factorial m) n (factorial (- n 1))) m)
  413.      (- (* 16 (^ a 2))
  414.     (* 2 (u 0 1) (at ((over d dx) (u x y)) (= x 0) (= y 1))))
  415.      (+ (^ a (^ b c)) (^ (^ a b) c))
  416.      )))
  417.  
  418. (define (textest)
  419.   (for-each
  420.    (lambda (b)
  421.      (tprint b tps:2d) (newline)
  422.      (tprint b tps:tex) (newline))
  423.    '(
  424.      (over (+ (^ a 2) c (* b x)) (+ 2 z))
  425.      (+ (^ (+ a b) (/ 1 2)) (^ e (/ 1 2)))
  426.      (arctan (arctan a))
  427.      (over (arctan
  428.         (over (- (/ (* 2 (^ b (/ 1 4)) x) (^ a (/ 1 4)))
  429.              (sqrt 2))
  430.           (sqrt 2)))
  431.        (* (^ 2 (/ 3 2)) (^ a (/ 3 4)) (^ b (/ 1 4))))
  432.      (over a (+ b c)))))
  433.  
  434. (define (mtest tps)
  435.   (for-each
  436.    (lambda (b) (tprint b tps) (newline))
  437.    '(
  438.      #((= x1 (negate (over 1 (sqrt 5))))
  439.        (= x2 (negate (over 2 (sqrt 5)))))
  440.      #(#((over 1 a) 0) #((negate (over b a)) 1))
  441.      #(#((^ a 2) 0) #((+ (* a b) b) 1)))))
  442.