home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / j / jacal1a0.zip / jacal / stdgrm.scm < prev    next >
Text File  |  1992-12-23  |  10KB  |  317 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright (C) 1989, 1990, 1991, 1992 Aubrey Jaffer.
  3. ;;; See the file `COPYING' for terms applying to this program.
  4.  
  5. ;;;; Here are the templates for 2 dimensional output
  6.  
  7. (define tps:2d
  8.   '(
  9.     (TEMPLATE:DEFAULT 140 #d0140 "(" #d1010 #(REST ", " #d2010) ")")
  10.     (TEMPLATE:BUNCH 140 "[" #d0010 #(REST ", " BREAK #d1010) "]")
  11.     (TEMPLATE:MATRIX 140 (#\[) #d0010 #(REST "  " #d1010) (#\]))
  12.     (TEMPLATE:PARENTHESIS 200 "(" #d1010 ")")
  13.     (- 100 #d1100 " - " BREAK #d2101 #(REST " - " BREAK #d3101))
  14.     (NEGATE 100 "- " #d1100)
  15.     (+ 100 #d1100 #(REST " + " BREAK #d2101))
  16.     (* 120 #d1120 #(REST " " #d2121))
  17.     (/ 120 #d1120 "/" #d2121)
  18.     (OVER 120 ((-1 #d1040)
  19.            (0 #\-)
  20.            (1 #d2040)))
  21.     (^ 140 #d1140 ((-1 #d2100)))
  22.     (= 80 #d1080 " = " BREAK #d2080 #(REST " = " BREAK #d3080))
  23.     (DIFFERENTIAL 170 #d1170 "'")
  24.     (SUCHTHAT 40 "{" #d1190 " | " #d2040 "}")
  25.     (DEFINE 200 #d1120 ": " ((0 #d2010)))
  26.     (RAPPLY 200 #d1200 ((1 #d2030 #(REST "," #d3010))))
  27.     (ABS 200 (#\|) #d1010 (#\|))
  28.     (BOX 200 ((-1 #\")
  29.           (0 (#\") #d1010 (#\"))
  30.           (1 #\")))
  31.     (FACTORIAL 160 #d1160 "!")
  32.     (INTEGRATE 120 ((-3 #(OPTIONAL #d4090))
  33.             (-2 "/ ")
  34.             (-1 "! ")
  35.             (0 "! ")
  36.             (1 "! ")
  37.             (2 "/ ")
  38.             (3 #(OPTIONAL #d3090)))
  39.            #d1090 "d" #d2120)
  40.     (LIMIT 90 ((0 "limit ")
  41.            (1 #d2090 "->" #d3090))
  42.        #d1090)
  43.     (SUM 90 ((-3 #(OPTIONAL #d4090))
  44.          (-2 "====")
  45.          (-1 "\\   ")
  46.          (0 " >  ")
  47.          (1 "/   ")
  48.          (2 "====")
  49.          (3 #(OPTIONAL #d2090 #(OPTIONAL" = " #d3090))))
  50.      #d1090)
  51.     (PROD 90 ((-3 " " #(OPTIONAL #d4090))
  52.           (-2 "/===/")
  53.           (-1 " ! ! ")
  54.           (0  " ! ! ")
  55.           (1  " ! ! ")
  56.           (2 #(OPTIONAL #d2090 #(OPTIONAL" = " #d3090))))
  57.       #d1090)
  58.     (AT 90 #d1090
  59.     ((-2 "!")
  60.      (-1 "!")
  61.      (0 "!")
  62.      (1 "!")
  63.      (2 "!"))
  64.     ((2 #d2010 #(REST ", " #d3010))))
  65.     (QED 100 "qed")
  66.     (% 200 "%")
  67.     (NCMULT 110 #d1109 " . " #d2109)
  68.     (^^ 210 #d1210 "^^" #d2210)
  69.     ))
  70.  
  71. (define tps:c
  72.   '(
  73.     (TEMPLATE:DEFAULT 140 #d0140 "(" #d1010 #(REST ", " #d2010) ")")
  74.     (TEMPLATE:BUNCH 140 "{" #d0010 #(REST ", " #d1010) "}")
  75.     (TEMPLATE:PARENTHESIS 200 "(" #d1010 ")")
  76.     (= 80 #d1080 " == " BREAK #d2080 #(REST "==" BREAK #d3080))
  77.     (- 100 #d1100 " - " BREAK #d2101 #(REST " - " BREAK #d3101))
  78.     (+ 100 #d1100 #(REST " + " BREAK #d2101))
  79.     (* 120 #d1120 #(REST " * " #d2121))
  80.     (NEGATE 90 "- " #d1090)
  81.     (/ 120 #d1120 "/" #d2121)
  82.     (OVER 120 #d1120 "/" #d2121)
  83.     (^ 140 "pow(" #d1140 ", " #d2100 ")")
  84.     (RAPPLY 200 #d1200 "[" #d2030 #(REST "," #d3010) "]")
  85.     (BOX 200 ((-1 #\")
  86.           (0 (#\") #d1010 (#\"))
  87.           (1 #\")))
  88.     (DEFINE 200 #d1120 " = " #d2010)
  89.     (SET 20 "set " #d1120 " " #d2010)
  90.     (SHOW 20 "show " #d1120)
  91.     ))
  92.  
  93. (define tps:std
  94.   '(
  95.     (TEMPLATE:DEFAULT 140 #d0140 "(" #d1010 #(REST ", " #d2010) ")")
  96.     (TEMPLATE:BUNCH 140 "[" #d0010 #(REST ", " #d1010) "]")
  97.     (TEMPLATE:PARENTHESIS 200 "(" #d1010 ")")
  98.     (= 80 #d1080 " = " BREAK #d2080 #(REST " = " BREAK #d3080))
  99.     (- 100 #d1100 " - " BREAK #d2101 #(REST " - " BREAK #d3101))
  100.     (+ 100 #d1100 #(REST " + " BREAK #d2101))
  101.     (* 120 #d1120 #(REST " * " #d2121))
  102.     (NEGATE 90 "- " #d1090)
  103.     (/ 120 #d1120 "/" #d2121)
  104.     (OVER 120 #d1120 "/" #d2121)
  105.     (^ 140 #d1140 "^" #d2140)
  106.     (DIFFERENTIAL 170 #d1170 "'")
  107.     (SUCHTHAT 40 "{" #d1190 " | " #d2040 "}")
  108.     (RAPPLY 200 #d1200 "[" #d2030 #(REST "," #d3010) "]")
  109.     (BOX 200 ((-1 #\")
  110.           (0 (#\") #d1010 (#\"))
  111.           (1 #\")))
  112.     (DEFINE 200 #d1120 ": " #d2010)
  113.     (SET 20 "set " #d1120 " " #d2010)
  114.     (SHOW 20 "show " #d1120)
  115.     (FACTORIAL 160 #d1160 "!")
  116.     (QED 100 "qed")
  117.     (% 200 "%")
  118.     (NCMULT 110 #d1109 " . " #d2109)
  119.     (^^ 210 #d1210 "^^" #d2210)
  120.     ))
  121.  
  122. (define tps:tex
  123.   '(
  124.     (TEMPLATE:TOP 0 "$" #d1000 "$")
  125.     (TEMPLATE:DEFAULT 140 #d0140 "\\left(" #d1010
  126.               #(REST ", " #d2010) "\\right)")
  127.     (TEMPLATE:BUNCH 140 "\\left[" #d0010 #(REST ", " BREAK #d1010) "\\right]")
  128.     (TEMPLATE:PARENTHESIS 200 "\\left(" #d1010 "\\right)")
  129.     (= 80 #d1080 " = " BREAK #d2080 #(REST " = " BREAK #d3080))
  130.     (- 100 #d1100 " - " BREAK #d2101 #(REST " - " BREAK #d3101))
  131.     (+ 100 #d1100 #(REST " + " BREAK #d2101))
  132.     (* 120 #d1120 #(REST " " #d2121))
  133.     (NEGATE 90 "- " #d1100)
  134.     (/ 120 #d1120 "/{" BREAK #d2121 "}")
  135.     (OVER 120 "{" #d1040 "}\\over{" BREAK #d2041 "}")
  136.     (^ 140 #d1140 "^{" #d2100 "}")
  137.     (DIFFERENTIAL 170 "{" #d1170 "}'")
  138.     (SUCHTHAT 40 "\\left\\{ " #d1190 " | " BREAK #d2040 "\\right\\}")
  139.     (RAPPLY 200 #d1200 "\\left[" #d2030 #(REST "," BREAK #d3010) "\\right]")
  140.     (ABS 200 "\\left|" #d1010 "\\right|")
  141. ;;;    (BOX 200 ((-1 #\")
  142. ;;;          (0 (#\") #d1010 (#\"))
  143. ;;;          (1 #\")))
  144.     (DEFINE 200 #d1120 ": " #d2010)
  145.     (SET 20 "set " #d1120 " " #d2010)
  146.     (SHOW 20 "show " #d1120)
  147.     (FACTORIAL 160 #d1160 "!")
  148.     (QED 100 "qed")
  149.     (% 200 "%")
  150.     ))
  151.  
  152. (defgrammar 'standard
  153.   (make-grammar
  154.    'standard                ;name
  155.    (lambda (grm)            ;reader
  156.      (set! *lex-rules* (grammar-lex-tab grm))
  157.      (set! *syn-rules* (grammar-read-tab grm))
  158.      (set! cgol:arg-separator #\,)
  159.      (cgol:top-parse #\;))
  160.    (make-hash-table 51)            ;lex-tab
  161.    (make-hash-table 51)            ;read-tab
  162.    inprint                ;writer
  163.    tps:std))                ;write-tab
  164.  
  165. (defgrammar 'disp2d
  166.   (make-grammar
  167.    'disp2d                    ;name
  168.    (lambda (grm)            ;reader
  169.      (set! *lex-rules* (grammar-lex-tab grm))
  170.      (set! *syn-rules* (grammar-read-tab grm))
  171.      (set! cgol:arg-separator #\,)
  172.      (cgol:top-parse #\;))
  173.    (grammar-lex-tab (get-grammar 'standard)) ;lex-tab
  174.    (grammar-read-tab (get-grammar 'standard)) ;read-tab
  175.    inprint                ;writer
  176.    tps:2d))                ;write-tab
  177.  
  178. (defgrammar 'tex
  179.   (make-grammar
  180.    'tex                    ;name
  181.    (lambda (grm)            ;reader
  182.      (set! *lex-rules* (grammar-lex-tab grm))
  183.      (set! *syn-rules* (grammar-read-tab grm))
  184.      (set! cgol:arg-separator #\,)
  185.      (cgol:top-parse #\;))
  186.    (make-hash-table 51)            ;lex-tab
  187.    (make-hash-table 51)            ;read-tab
  188.    inprint                ;writer
  189.    tps:tex))                ;write-tab
  190.  
  191. ;;;;The parse tables.
  192.  
  193. ;(require "parse.scm")
  194. ;(set! *lex-defs* (make-hash-table 51))
  195. ;(set! *syn-defs* (make-hash-table 37))
  196. (set! *lex-defs* (grammar-lex-tab (get-grammar 'standard)))
  197. (set! *syn-defs* (grammar-read-tab (get-grammar 'standard)))
  198.  
  199. ;;;Syntax definitions for STANDARD GRAMMAR
  200. (lex:def-class 70 '(#\^) #f)
  201. (lex:def-class 49 '(#\*) #f)
  202. (lex:def-class 50 '(#\/) #f)
  203. (lex:def-class 51 '(#\+ #\-) #f)
  204. (lex:def-class 20 '(#\|) #f)
  205. (lex:def-class 30 '(#\< #\> #\= #\: #\~) #f)
  206. (lex:def-class 40 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  207.            (lambda (l) (string->number (list->string l))))
  208. (lex:def-class 41
  209.         '(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
  210.           #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
  211.           #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
  212.           #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
  213.           #\@ #\_ #\% #\?)
  214.         #f)
  215. (lex:def-class (lambda (chr) (or (eqv? #\" chr) (eof-object? chr)))
  216.         '(#\")
  217.         (lambda (l)
  218.           (lex:read-char) (string->symbol (list->string (cdr l)))))
  219. ;;; TeX style comment.  Better to do using CGOL:COMMENTFIX.
  220. ;(lex:def-class (lambda (chr) (or (eqv? #\$ chr) (eof-object? chr)))
  221. ;           '(#\$)
  222. ;           (lambda (l) (lex:read-char) (lex)))
  223. ;;; Ignore leading whitespace.
  224. (lex:def-class 0 (list slib:tab slib:form-feed #\  #\newline) #f)
  225.  
  226. ;;; Delimiters and Separators
  227. (cgol:separator #\, 10)
  228. (cgol:delim #\; 0)
  229. (cgol:delim (integer->char 0) 0)        ;EOF
  230. ;(cgol:postfix #\$ (lambda (x) (write x)) 0)
  231.  
  232. ;;;prefix operators
  233. (cgol:prefix '+ #f 100)
  234. (cgol:prefix '- 'negate 100)
  235. (cgol:prefix '+/- 'u+/- 100)
  236. (cgol:prefix '-/+ 'u-/+ 100)
  237. (cgol:prefix '(NOT ~) 'impl_not 70)
  238. (cgol:prefix ":" 'SetTemplate! 20)
  239.  
  240. ;;;postfix operators
  241. (cgol:postfix #\! 'factorial 160)
  242. (cgol:postfix #\' 'Differential 170)
  243.  
  244. ;;;infix operators
  245. ;(cgol:infix 'X 'crossproduct 111 110)
  246. (cgol:infix #\. 'ncmult 110 109)
  247. (cgol:infix '(^ **) '^ 140 139)
  248. (cgol:infix '^^ '^^ 210 210)
  249. (cgol:infix '(":=" ":") 'define 180 20)
  250. (cgol:infix '= '= 80 80)
  251. (cgol:infix '(~= <>) 'make-not-equal 80 80)
  252. (cgol:infix 'mod 'mod 70 70)
  253.  
  254. ;(cgol:infix "" '* 120 120)        ;null operator
  255.  
  256. ;;;nary operators
  257. (cgol:nary '* '* 120)
  258. (cgol:nary '+ '+ 100)
  259. (cgol:nary '- '- 100)
  260. (cgol:nary '+/- 'b+/- 100)
  261. (cgol:nary '-/+ 'b-/+ 100)
  262. (cgol:nary '/ '/ 120)
  263. (cgol:nary '(AND #\&) '& 60)
  264. (cgol:nary 'OR 'or 50)
  265.  
  266. ;;;special operators
  267. (cgol:inmatchfix #\( #f #\) 200)
  268. (cgol:inmatchfix #\[ 'rapply #\] 200)
  269.  
  270. ;;;matchfix operators
  271. (cgol:matchfix #\( #f #\))
  272. (cgol:matchfix #\[ vector #\])
  273. (cgol:matchfix #\{ 'or #\})
  274. (cgol:matchfix #\\ 'lambda #\;)
  275.  
  276. (cgol:infix "|" 'suchthat 190 40)
  277. (cgol:prefix 'load 'load 50)
  278. (cgol:nofix '% '%)
  279. (cgol:nofix '(QED bye exit) 'qed)
  280.  
  281. (cgol:commentfix
  282.  '/* (lambda ()
  283.        (define echoing (not (eq? (get-grammar 'null) *echo-grammar*)))
  284.        (do ((c (lex:read-char) (lex:read-char)))
  285.        ((or (eof-object? c)
  286.         (and (char=? #\* c)
  287.              (char=? #\/ (lex:peek-char))))
  288.         (lex:read-char))
  289.      (if echoing (display c)))))
  290.  
  291. ;;;rest operator reads expressions up to next delimiter.
  292. (cgol:rest 'set 'set 10)
  293. (cgol:rest 'show 'show 10)
  294.  
  295. (set! *input-grammar* (get-grammar 'standard))
  296. (set! *output-grammar* (get-grammar 'disp2d))
  297.  
  298. ;(set! *lex-defs* (grammar-lex-tab (get-grammar 'TeX)))
  299. ;(set! *syn-defs* (grammar-read-tab (get-grammar 'TeX)))
  300.  
  301. ;;;Syntax definitions for TEX GRAMMAR
  302. ;(lex:def-class 30 '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  303. ;           (lambda (l) (string->number (list->string l))))
  304. ;(lex:def-class (let ((seen1 #f))
  305. ;         (lambda (chr)
  306. ;           (cond (seen1 (not (or (char-whitespace? chr)
  307. ;                     (char-numeric? chr))))
  308. ;             (else (set! seen1 #t) #f))))
  309. ;           '(#\\)
  310. ;           #f)
  311. ;;; TeX style comment.  Better to do using CGOL:COMMENTFIX.
  312. ;(lex:def-class (lambda (chr) (or (eqv? #\$ chr) (eof-object? chr)))
  313. ;           '(#\$)
  314. ;           (lambda (l) (lex:read-char) (lex)))
  315. ;;; Ignore leading whitespace.
  316. ;(lex:def-class 0 (list slib:tab slib:form-feed #\  #\newline) #f)
  317.