home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / b116_1 / jacal / builtin < prev    next >
Text File  |  1993-11-03  |  18KB  |  675 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992, 1993 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;;; First, what case are symbols in?  Determine the standard case:
  6. (define char-standard-case
  7.   (cond ((not (string=? (symbol->string 'a) (symbol->string 'A)))
  8.      char-downcase)
  9.     ((string=? (symbol->string 'a) "A")
  10.      char-upcase)
  11.     ((string=? (symbol->string 'A) "a")
  12.      char-downcase)
  13.     (else
  14.      char-downcase)))
  15. (define (string-standard-case s)
  16.   (set! s (string-copy s))
  17.   (do ((i 0 (+ 1 i))
  18.        (sl (string-length s)))
  19.       ((>= i sl) s)
  20.       (string-set! s i (char-standard-case (string-ref s i)))))
  21. (define (bltn:error . args)
  22.   (apply math:warn args)
  23.   novalue)
  24.  
  25. ;;;Predefined Constants
  26. (define expl:t (var->expl (sexp->var 't)))
  27. (define $ (string->var ":@"))
  28. (define $-pri (+ -1 char-code-limit))
  29. (var:set-pri! $ $-pri)
  30. (define ($? v) (or (eq? v $) (= (var:pri v) $-pri)))
  31. (define d$
  32.   (var:differential $)) ;used only in total-differential in norm.scm
  33. (var:set-pri! d$ (+ -2 char-code-limit))
  34. (define $1 (string->var "@1"))
  35. (define $2 (string->var "@2"))
  36. (define $3 (string->var "@3"))
  37.  
  38. (define _$ (string->var "::@"))
  39. (define $1+$2 (list $2 (list $1 0 1) 1))
  40. (define $1-$2 (list $2 (list $1 0 1) -1))
  41. (define _-$1 (list $1 0 -1))
  42. (define $1*$2 (list $2 0 (list $1 0 1)))
  43. (define $1/$2 (list $ (list $1 0 1) (list $2 0 -1)))
  44. (define $1=$2 (list $= $2 (list $1 0 -1) 1))
  45. (define cidentity (list $1 0 1))
  46.  
  47. (define _^ (list (string->var "^") 0 1))
  48. (define _^^ (list (string->var "^^") 0 1))
  49. (define _partial (list (string->var "partial") 0 1))
  50. (define _ncmult (list (string->var "ncmult") 0 1))
  51.  
  52. ;;; canoncial functions for vect.scm
  53. (define $1-$2*$3 (list $3 (list $1 0 1) (list $2 0 -1)))
  54. (define _-$1/$2 (make-rat (list $1 0 -1) (list $2 0 1)))
  55. (define $1*$2+$3 (list $3 (list $2 0 (list $1 0 1)) 1))
  56.  
  57. ;;; set up initial radical and extension
  58. (define %sqrt1 (defext (sexp->var '%sqrt1) (list $ 1 0 -1)))
  59. (var:set-pri! %sqrt1 5)
  60. (define %i (defext (sexp->var '%i) (list $ -1 0 -1)))
  61. (var:set-pri! %i 5)
  62. (define radical-defs (list (extrule %i) (extrule %sqrt1)))
  63. (define _+/-$1 (list $1 0 (list %sqrt1 0 1)))
  64. (define _-/+$1 (list $1 0 (list %sqrt1 0 -1)))
  65. (define $1+/-$2 (list $2 (list $1 0 1) (list %sqrt1 0 1)))
  66. (define $1-/+$2 (list $2 (list $1 0 1) (list %sqrt1 0 -1)))
  67.  
  68. (define novalue (var->expl (sexp->var '?)))
  69. (define (novalue? x) (equal? novalue x))
  70.  
  71. (define *flags* '())
  72. (define flag-associator (alist-associator eq?))
  73. (define flag-inquirer (alist-inquirer eq?))
  74. (define (list-of-flags)
  75.   (define flags '())
  76.   (alist-for-each (lambda (k v) (set! flags (cons k flags))) *flags*)
  77.   flags)
  78.  
  79. ;(define *flags* (make-hash-table 5))
  80. ;(define flag-associator (hash-associator eq?))
  81. ;(define flag-inquirer (hash-inquirer eq?))
  82. ;(define (list-of-flags)
  83. ;  (define flags '())
  84. ;  (hash-for-each (lambda (k v) (set! flags (cons k flags))) *flags*)
  85. ;  flags)
  86.  
  87. (define (defflag name setter getter)
  88.   (set! *flags* (flag-associator *flags* name (cons setter getter)))
  89.   name)
  90.  
  91. (define flag:setter car)
  92. (define flag:getter cdr)
  93.  
  94. (define (flag-set name . values)
  95.   (let ((flag (flag-inquirer *flags* name)))
  96.     (cond ((not flag) (bltn:error 'flag name 'is-not-defined))
  97.       ((flag:setter flag) (apply (flag:setter flag) flag values) novalue)
  98.       (else (bltn:error 'flag name 'can-not-be-set)))))
  99.  
  100. (define (flag-get name . rest)
  101.   (let ((flag (flag-inquirer *flags* name)))
  102.     (cond ((not flag) (bltn:error 'flag name 'is-not-defined))
  103.       ((flag:getter flag) (apply (flag:getter flag) flag rest))
  104.       (else (bltn:error 'flag name 'can-not-be-read)))))
  105.  
  106. (defflag 'ingrammar
  107.   (lambda (f v)
  108.     (define name (var:sexp (expl->var v)))
  109.     (cond ((get-grammar name)
  110.        (set! *input-grammar* (get-grammar name)))
  111.       (else
  112.        (bltn:error 'grammar name 'not-known))))
  113.   (lambda (f) (var->expl (sexp->var (grammar-name *input-grammar*)))))
  114.  
  115. (defflag 'outgrammar
  116.   (lambda (f v)
  117.     (define name (var:sexp (expl->var v)))
  118.     (cond ((get-grammar name)
  119.        (set! *output-grammar* (get-grammar name)))
  120.       (else
  121.        (bltn:error 'grammar name 'not-known))))
  122.   (lambda (f) (var->expl (sexp->var (grammar-name *output-grammar*)))))
  123.  
  124. (defflag 'echogrammar
  125.   (lambda (f v)
  126.     (define name (var:sexp (expl->var v)))
  127.     (cond ((get-grammar name)
  128.        (set! *echo-grammar* (get-grammar name)))
  129.       (else
  130.        (bltn:error 'grammar name 'not-known))))
  131.   (lambda (f) (var->expl (sexp->var (grammar-name *echo-grammar*)))))
  132.  
  133. (defflag 'grammars
  134.   #f
  135.   (lambda (f)
  136.     (map (lambda (g) (var->expl (sexp->var g))) (list-of-grammars))))
  137.  
  138. (define (set-boolean v)
  139.   (define val (var:sexp (expl->var v)))
  140.   (case val
  141.     ((off 0 false) #f)
  142.     ((on 1 true) #t)
  143.     (else (bltn:error 'expected-boolean v))))
  144.  
  145. (define (show-boolean v)
  146.   (var->expl (sexp->var (if v 'on 'off))))
  147.  
  148. (defflag 'horner
  149.   (lambda (f v) (set! horner (set-boolean v)))
  150.   (lambda (f) (show-boolean horner)))
  151.  
  152. (defflag 'trace
  153.   (lambda (f v) (set! math:trace (set-boolean v)))
  154.   (lambda (f) (show-boolean math:trace)))
  155.  
  156. (defflag 'debug
  157.   (lambda (f v) (set! math:debug (set-boolean v)))
  158.   (lambda (f) (show-boolean math:debug)))
  159.  
  160. (defflag 'phases
  161.   (lambda (f v) (set! math:phases (set-boolean v)))
  162.   (lambda (f) (show-boolean math:phases)))
  163.  
  164. (defflag 'linkradicals
  165.   (lambda (f v) (set! linkradicals (set-boolean v)))
  166.   (lambda (f) (show-boolean linkradicals)))
  167.  
  168. (defflag 'version
  169.   #f
  170.   (lambda (f)
  171.     (var->expl (string->var *jacal-version*))))
  172.  
  173. (defflag 'all
  174.   #f
  175.   (lambda (f)
  176.     (block-write-strings
  177.      (sort! (map symbol->string (list-of-flags))
  178.         string<?))
  179.     novalue))
  180.  
  181. (defflag 'prompt
  182.   (lambda (f v)
  183.     (set! newlabelstr (var->string (expl->var v)))
  184.     (set! newlabelsym (string->symbol newlabelstr))
  185.     novalue)
  186.   (lambda (f) (var->expl (string->var newlabelstr))))
  187.  
  188. (defflag 'page
  189.   (lambda (f v)
  190.     (define val (if (number? v) v (var:sexp (expl->var v))))
  191.     (set! page-height
  192.       (case val ((off 0 false) #f)
  193.         ((on 1 true) #t)
  194.         (else (if (number? val) val
  195.               (bltn:error 'expected-boolean-or-number v))))))
  196.   (lambda (f) (if (boolean? page-height)
  197.           (show-boolean page-height)
  198.           page-height)))
  199.  
  200. (defflag 'width
  201.   (lambda (f v)
  202.     (define val (if (number? v) v (var:sexp (expl->var v))))
  203.     (set! page-width
  204.       (case val ((off 0 false) #f)
  205.         ((on 1 true) #t)
  206.         (else (if (number? val) val
  207.               (bltn:error 'expected-boolean-or-number v))))))
  208.   (lambda (f) (if (boolean? page-width)
  209.           (show-boolean page-width)
  210.           page-width)))
  211.  
  212. (defflag 'priority
  213.   (lambda (f v p)
  214.     (if (not (and (number? p) (< 0 p lambda-var-pri))) (math:error))
  215.     (var:set-pri! (expl->var v) p))
  216.   (lambda args
  217.     (if (null? (cdr args))
  218.     (let ((l (list-of-vars)))
  219.       (block-write-strings (map object->string
  220.                     (map var:sexp (sort! l var:>))))
  221.       novalue)
  222.     (var:pri (expl->var (cadr args))))))
  223.  
  224. ;(define transcript-name #f)
  225. ;(defflag 'transcript
  226. ;  (lambda (f v)
  227. ;    (define file (and v (not (null? v)) (var->string (expl->var v))))
  228. ;    (if v (transcript-on file) (transcript-off))
  229. ;    (set! transcript-name file))
  230. ;  (lambda (f) (if transcript-name
  231. ;          (var->expl (string->var transcript-name))
  232. ;          '#())))
  233.  
  234. ;;;; Built in functions
  235. (defbltn 'set
  236.   (lambda (name . values)
  237.     (apply flag-set (var:sexp (expl->var name)) values)))
  238.  
  239. (defbltn 'show
  240.   (lambda (name . rest) (apply flag-get
  241.                    (var:sexp (expl->var name))
  242.                    rest)))
  243.  
  244. (defbltn 'commands
  245.   (lambda ()
  246.     (block-write-strings
  247.      (sort! (map object->string (list-of-procedure-defsyms))
  248.         string<?))
  249.     novalue))
  250.  
  251. (defbltn '%
  252.   (lambda () %))
  253.  
  254. (defbltn 'depends
  255.   (lambda (x) (map var->expl (var:depends (expl->var x)))))
  256.  
  257. (defbltn 'args
  258.   (lambda (x) (cdr (func-arglist (expl->var x)))))
  259.  
  260. (defbltn 'func
  261.   (lambda (x) (car (func-arglist (expl->var x)))))
  262.  
  263. (defbltn 'describe
  264.   (lambda (x)
  265.     (cond
  266.      ((and (expl:var? x)
  267.        (info:describe (var:sexp (expl->var x)))))
  268.      ((bunch? x) (display (bunch-type x)) (newline))
  269.      ((not (expl:var? x)) (display (scalar-type x)))
  270.      (else (describe-var (expl->var x))))
  271.     (if (clambda? x)
  272.     (let ((hlv (licits:max-lambda-position (if (eqn? x) (eqn->poly x) x))))
  273.       (tran:display 'function-of-)
  274.       (display hlv)
  275.       (if (= 1 hlv) (tran:display 'argument) (tran:display 'arguments))))
  276.     novalue))
  277.  
  278. (define (describe-var v)
  279.   (cond ((var:differential? v)
  280.      (tran:display 'differential-)
  281.      (set! v (var:nodiffs v))))
  282.   (display
  283.    (cond ((radicalvar? v) 'radical)
  284.      ((not (symbol? (var:sexp v))) 'application)
  285.      (else 'variable))))
  286.  
  287. (define (scalar-type x)
  288.   (cond ((number? x) 'number)
  289.     ((eqn? x) 'equation)
  290.     ((expl? x) 'polynomial)
  291.     ((rat? x) 'rational-expression)
  292.     ((impl? x) 'implicit-expression)
  293.     (else 'unknown)))
  294.  
  295. (define (bunch-type x)
  296.   (cond ((matrix? x) 'matrix)
  297.     ((row? x) 'row-vector)
  298.     ((column? x) 'column-vector)
  299.     (else 'bunch)))
  300.  
  301. (defbltn 'example
  302.   (lambda (x) (info:example x)))
  303.  
  304. (define (terms) (paginate-file (in-vicinity jacal-vicinity "COPYING")))
  305. (defbltn 'terms (lambda () (terms) novalue))
  306.  
  307. (define (help) (paginate-file (in-vicinity jacal-vicinity "HELP")))
  308. (defbltn 'help (lambda () (help) novalue))
  309.  
  310. (define (boolify x)
  311.   (var->expl (sexp->var (if x 'true 'false))))
  312.  
  313. (defbltn 'verify
  314.   (lambda (try expect)
  315.     (let ((tv (normalize try)) (ev (normalize expect)))
  316.       (cond ((equal? tv ev) (boolify #t))
  317.         (else
  318.          (display-diag (tran:translate 'Did-not-verify:))
  319.          (newline-diag)
  320.          (write-sexp (math->sexp (list tv ev) horner) *output-grammar*)
  321.          (if math:debug (do-more))
  322.          (boolify #f))))))
  323.  
  324. (defbltn 'Differential
  325.   (lambda (obj) (total-differential obj)))
  326.  
  327. (defbltn 'negate
  328.   (lambda (obj) (app* _-$1 obj)))
  329.  
  330. (defbltn 'u+/-
  331.   (lambda (obj) (app* _+/-$1 obj)))
  332.  
  333. (defbltn 'u-/+
  334.   (lambda (obj) (app* _-/+$1 obj)))
  335.  
  336. (defbltn '^                ;need to do expt also
  337.   (lambda (x exp)
  338.     (if (and (expl? x) (number? exp) (positive? exp))
  339.     (poly:^ x (normalize exp))
  340.     (^ (expr x) exp))))
  341.  
  342. (defbltn '^^                ;need to do ncexpt also
  343.   (lambda (a pow) (ncexpt (exprs a) (normalize pow))))
  344.  
  345. (defbltn '*
  346.   (lambda args (reduce (lambda (x y)
  347.              (if (and (expl? x) (expl? y))
  348.                  (poly:* x y)
  349.                  (app* $1*$2 x y)))
  350.                args)))
  351.  
  352. (defbltn '+
  353.   (lambda args (reduce (lambda (x y)
  354.              (if (and (expl? x) (expl? y))
  355.                  (poly:+ x y)
  356.                  (app* $1+$2 x y)))
  357.                args)))
  358.  
  359. (defbltn '-
  360.   (lambda args (reduce (lambda (x y)
  361.              (if (and (expl? x) (expl? y))
  362.                  (poly:- x y)
  363.                  (app* $1-$2 x y)))
  364.                args)))
  365.  
  366. (defbltn 'b+/-
  367.   (lambda args (reduce (lambda (x y) (app* $1+/-$2 x y)) args)))
  368.  
  369. (defbltn 'b-/+
  370.   (lambda args (reduce (lambda (x y) (app* $1-/+$2 x y)) args)))
  371.  
  372. (defbltn '/
  373.   (lambda args (reduce (lambda (x y) (app* $1/$2 x y)) args)))
  374.  
  375. (defbltn 'over
  376.   (lambda args (reduce (lambda (x y) (app* $1/$2 x y)) args)))
  377.  
  378. (defbltn 'bunch
  379.   (lambda args args))
  380.  
  381. (defbltn 'rapply
  382.   (lambda args (apply rapply args)))
  383.  
  384. (defbltn 'or
  385.   (lambda args
  386.     (poleqn->licit (reduce poly:* (map licit->poleqn args)))))
  387.  
  388. (defbltn '=
  389.   (lambda (x y) (app* $1=$2 x y)))
  390.  
  391. (defbltn 'qed
  392.   (lambda ()
  393.     (cleanup-handlers!)
  394.     (math:exit #t)))
  395.  
  396. (defbltn 'quit
  397.   (lambda ()
  398.     (cleanup-handlers!)
  399.     (quit)))
  400.  
  401. ;;;; User callable functions
  402.  
  403. (defbltn 'listofvars
  404.   (lambda (exp)
  405.     (let ((deps '()))
  406.       (licits:for-each (lambda (poly) (set! deps (union (alg:vars poly) deps)))
  407.                exp)
  408.       (map var->expl (remove $ deps)))))
  409.  
  410. (defbltn 'coeff
  411.   (lambda (p var . optional)
  412.     (let ((ord (if (null? optional) 1 (car optional))))
  413.       (poly:coeff p (expl->var var) (plicit->integer ord)))))
  414.  
  415. (defbltn 'num
  416.   (lambda (exp) (num (expr:normalize exp))))
  417.  
  418. (defbltn 'denom
  419.   (lambda (exp) (denom (expr:normalize exp)))) 
  420.  
  421. (defbltn 'divide
  422.   (lambda (dividend divisor . vars)
  423.     (set! dividend (licit->polxpr dividend))
  424.     (set! divisor (licit->polxpr divisor))
  425.     (poly:pdiv dividend divisor (if (null? vars)
  426.                     (if (number? divisor)
  427.                     (if (number? dividend) 0
  428.                         (car dividend))
  429.                     (car divisor))
  430.                     (expl->var (car vars))))))
  431.  
  432. (defbltn 'content
  433.   (lambda (poly var)
  434.     (let* ((var (expl->var var))
  435.        (poly (promote var (licit->polxpr poly)))
  436.        (cont (apply poly:gcd* (cdr poly))))
  437.       (list cont (poly:/ poly cont)))))
  438.  
  439. ;;; This is user callable GCD.
  440. (defbltn 'gcd
  441.   (lambda args
  442.     (if (null? args) 0
  443.     (reduce poly:gcd (map licit->polxpr args)))))
  444.  
  445. (defbltn 'mod
  446.   (lambda (licit polxpr)
  447.     (poleqn->licit (alg:mod (licit->poleqn licit) (licit->polxpr polxpr)))))
  448.  
  449. ;;; This is user callable RESULTANT.  It always operates on
  450. ;;; polynomials and does not know about extensions etc.
  451. (defbltn 'resultant
  452.   (lambda (a b v)
  453.     (let ((res (poly:resultant
  454.         (licit->polxpr a)
  455.         (licit->polxpr b)
  456.         (expl->var v))))
  457.       res))) 
  458.  
  459. (defbltn 'sylvester
  460.   (lambda (p1 p2 var)
  461.     (sylvester (licit->polxpr p1)
  462.            (licit->polxpr p2)
  463.            (expl->var var))))
  464.  
  465. (defbltn 'discriminant
  466.   (lambda (poly var)
  467.     (set! poly (licit->polxpr poly))
  468.     (set! poly (poly:/ poly (if (> (leading-number poly) 0)
  469.                 (poly:num-cont poly)
  470.                 (- (poly:num-cont poly)))))
  471.     (let* ((v (expl->var var))
  472.        (deg (poly:degree poly v)))
  473.       (if (> deg 1)
  474.       (poly:* (quotient (* deg (- deg 1)) 2)
  475.           (poly:resultant (poly:diff poly v) poly v))
  476.       0))))
  477.  
  478. (defbltn 'eliminate
  479.   (lambda (eqns vars)
  480.     (poleqns->licits (eliminate (licits->poleqns eqns) (variables (normalize vars))))))
  481.  
  482. (defbltn 'PolyElim
  483.   (lambda (eqns vars)
  484.     (poleqns->licits (poly:elim (licits->poleqns eqns) (variables vars)))))
  485.  
  486. (defbltn 'factor
  487.   (lambda (poly)
  488.     (let ((e (licit->polxpr poly)))
  489.       (cond ((number? e) (require 'prime) ;autoload from SLIB
  490.              (sort! (factor e) <))
  491.         (else (poly:factorq e))))))
  492.  
  493. (defbltn 'prime?
  494.   (lambda (n)
  495.     (let ((e (licit->polxpr n)))
  496.       (cond ((number? e) (require 'prime) ;autoload from SLIB
  497.              (boolify (prime? e)))
  498.         (else (bltn:error 'Not-a-Number n))))))
  499.  
  500. (defbltn 'matrix
  501.   (lambda args (apply matrix args)))
  502.  
  503. (defbltn 'genmatrix
  504.   (lambda (fun i2 j2 . i1j1)
  505.     (let ((i1 1) (j1 1))
  506.       (cond ((null? i1j1))
  507.         ((begin (set! i1 (car i1j1))
  508.             (set! i1j1 (cdr i1j1))
  509.             (set! j1 i1)
  510.             (null? i1j1)))
  511.         ((begin (set! j1 (car i1j1))
  512.             (set! i1j1 (cdr i1j1))
  513.             (null? i1j1)))
  514.         (else (math:error 'genmatrix wna)))
  515.       (mtrx:genmatrix
  516.        fun 
  517.        (plicit->integer i2)
  518.        (plicit->integer j2)
  519.        (plicit->integer i1)
  520.        (plicit->integer j1)))))
  521.  
  522. (defbltn 'augcoefmatrix
  523.   (lambda (eqns vars)
  524.     (augcoefmatrix (licits->poleqns eqns) (variables vars))))
  525.  
  526. (defbltn 'coefmatrix
  527.   (lambda (eqns vars)
  528.     (coefmatrix (licits->poleqns eqns) (variables vars))))
  529.  
  530. (defbltn 'rank
  531.   rank)
  532.  
  533. (defbltn 'ident
  534.   (lambda (n) (mtrx:scalarmatrix n 1)))
  535.  
  536. (defbltn 'scalarmatrix
  537.   (lambda (n x) (mtrx:scalarmatrix (plicit->integer n) x)))
  538.  
  539. (defbltn 'diagmatrix
  540.   (lambda args (mtrx:diagmatrix args)))
  541.  
  542. (defbltn 'determinant
  543.   (lambda (m) (determinant m)))
  544.  
  545. (defbltn 'charpoly
  546.   charpoly)
  547.  
  548. (defbltn 'crossproduct
  549.   (lambda (x y) (crossproduct x y)))
  550.  
  551. (defbltn 'dotproduct
  552.   (lambda (x y) (dotproduct x y)))
  553.  
  554. (defbltn 'ncmult
  555.   (lambda (x y) (ncmult x y)))
  556.  
  557. (defbltn 'row
  558.   (lambda (m i)
  559.     (if (matrix? m)
  560.     (list-ref m (+ -1 (plicit->integer i)))
  561.     (bltn:error 'Row-of-non-matrix?:- M))))
  562.  
  563. (defbltn 'col
  564.   (lambda (m i)
  565.     (cond ((matrix? m)
  566.        (map (lambda (row)
  567.           (list (list-ref row (+ -1 (plicit->integer i)))))
  568.         m))
  569.       ((bunch? m) (list-ref m (plicit->integer i)))
  570.       (else (bltn:error 'Column-of-non-matrix?:- M)))))
  571.  
  572. (defbltn 'minor
  573.   (lambda (m i j)
  574.     (mtrx:minor m (plicit->integer i) (plicit->integer j))))
  575.  
  576. (defbltn 'cofactor
  577.   (lambda (m i j)
  578.     (cofactor m (plicit->integer i) (plicit->integer j))))
  579.  
  580. (defbltn 'transpose
  581.   (lambda (m) (transpose m)))
  582.  
  583. (defbltn 'CartProd
  584.   (lambda (m) (cart-prod m)))
  585.  
  586. (defbltn 'Elementwise
  587.   (lambda (f . args)
  588.     (apply map (lambda args (sapply f args)) args)))
  589.  
  590. (defbltn 'finv
  591.   (lambda (f)
  592.     (fcinverse f)))
  593.  
  594. (defbltn 'load
  595.   (lambda (file)
  596.     (load (var->string (expl->var file)))
  597.     file))
  598.  
  599. (defbltn 'require
  600.   (lambda (file)
  601.     (load (in-vicinity jacal-vicinity (var->string (expl->var file))))
  602.     file))
  603.  
  604. (defbltn 'batch
  605.   (lambda (file)
  606.     (batch (var->string (expl->var file)))
  607.     novalue))
  608.  
  609. (defbltn 'transcript
  610.   (lambda files
  611.     (cond ((null? files) 
  612.        (transcript-off)
  613.        novalue)
  614.       ((not (null? (cdr files))) (bltn:error 'transcript wna files))
  615.       (else
  616.        (let ((file (var->string (expl->var (car files)))))
  617.          (transcript-on file)
  618.          (car files))))))
  619.  
  620. (defbltn 'system
  621.   (lambda (command)
  622.     (system (var->string (expl->var command)))
  623. ;    command        ;uncomment this line if system doesn't return nicely
  624.     ))
  625.  
  626. (defbltn 'coeffs
  627.   (lambda (poly var)
  628.     (if (not (and (expl? poly) (not (number? poly))))
  629.     (bltn:error 'not-a-polynomial? poly)
  630.     (cdr (promote (expl->var var) poly)))))
  631.  
  632. (defbltn 'poly
  633.   (lambda (var . args)
  634.     (reduce (lambda (p c) (poly:+ (poly:* p var) c))
  635.         (cond ((> (length args) 1) args)
  636.           ((not (and (= (length args) 1) (bunch? (car args))))
  637.            (bltn:error 'not-a-bunch? (car args)))
  638.           (else (car args))))))
  639.  
  640. (defbltn 'diff
  641.   (lambda (exp . args)
  642.     (reduce-init diff exp (map expl->var args))))
  643.  
  644. (defbltn 'PolyDiff
  645.   (lambda (exp . args)
  646.     (reduce-init expls:diff exp (map expl->var args))))
  647.  
  648. (defbltn 'partial
  649.   (lambda (func . args)
  650.     (cond ((number? func) (bltn:error 'not-a-function? func))
  651.       ((null? args) (bltn:error 'no-variables?))
  652.       ((not (clambda? func)) (apply deferop _partial func args))
  653.       (else
  654.        (reduce-init
  655.         diff func
  656.         (map (lambda (a)
  657.            (cond ((and (number? a) (positive? a)) (lambda-var a 0))
  658.              ((clambda? a) (expl->var a))
  659.              (else (math:error 'partial-with-respect-to? a))))
  660.          args))))))
  661.  
  662. ;;; commands for debugging:
  663.  
  664. (defbltn 'chain
  665.   (lambda (exp)
  666.     (let ((e (expl->var exp)))
  667.       (poly->eqn (chain-rule e (var:differential e))))))
  668.  
  669. (defbltn 'shadow
  670.   (lambda (x) (map (lambda (v) (if v (var->expl v) '()))
  671.            (or (vector-ref (expl->var x) 4) '()))))
  672.  
  673. (defbltn 'extrule
  674.   (lambda (x) (poly->eqn (or (extrule (expl->var x)) 0))))
  675.