;;; ;;; David Carlisle ;;; davidc@nag.co.uk ;;; ;;; Copyright 1998 Nag Ltd, The OpenMath Consortium. Esprit Project 24.969. ;;; ;;; COLOUR ;;; ;;; Just RGB colour supported currentlly (define (rgb-color r g b) (color (color-space "ISO/IEC 10179:1996//Color-Space Family::Device RGB") r g b)) ;;; CONTENT MathML ;;; ;;; Content MathML is mainly implemented directly with element ;;; declarations, and process-children. there is not too much ;;; need for node list processing. ;;; ;;; Currently many attributes for font changes and spacing are silently ;;; ignored. ;;; ;;; The mo element goes to some trouble to get its attributes as specified ;;; in the MathML recomendation, but currently doesn't do much with them. ;;; mrow ;;; should check attributes (this comment applies to most elements ;;; but won't be repeated (element mrow (process-children-trim)) ;;; mi ;;; Math Identifier Defaults to italic. ;;; Ought to switch between math italic and text italic ;;; for multi letter identifiers (or just in tex backend?) (element mi (make math-sequence font-posture: (let ((fnt (if(attribute-string "fontstyle") (attribute-string "fontstyle") "italic"))) (if (equal? "normal" fnt) 'upright (if (equal? "italic" fnt) 'italic #f))) (process-children-trim))) ;;; mn ;;; Same for numbers. (element mn (make math-sequence font-posture: (let ((fnt (if(attribute-string "fontstyle") (attribute-string "fontstyle") "normal"))) (if (equal? "normal" fnt) 'upright (if (equal? "italic" fnt) 'italic #f))) (process-children-trim))) ;;; mtext ;;; Bits of non-math (element mtext (make unmath (process-children-trim))) ;;; mspace ;;; Grumble grumble it seems extraordinarily complicated to copy ;;; a length from an attribute on the element to a keyword to a make ;;; function. Also the rtf backend doesn't really support line-field ;;; I couldn't get inline-space characters to work either. (element mspace (make line-field field-width: (let ((x (attribute-value "width" (current-node)))) (measurement-to-length (if (attribute-string "width") (attribute-string "width") "0pt"))))) ;;; ms ;;; Doesn't work right in tex backend: How do you specify mono space font ;;; without specifying what font to use. (element ms (make unmath font-posture: 'upright font-family-name: "iso-monospace" (literal "\"") (process-children-trim) (literal "\""))) ;;; mfrac ;;; fractions. (element mfrac (make fraction (let ((nl (children(current-node)))) (sosofo-append (make math-sequence label: 'numerator (process-node-list (node-list-first nl))) (make math-sequence label: 'denominator (process-node-list (node-list-rest nl))))))) ;;; msqrt mroot ;;; Radicals (element msqrt (make radical (process-children-trim))) (element mroot (make radical (let ((nl (children(current-node)))) (sosofo-append (make math-sequence (process-node-list (node-list-first nl))) (make math-sequence label: 'degree (process-node-list (node-list-rest nl))))))) ;;; mstyle ;;; Style, what style? (element mstyle (make math-sequence (process-children-trim))) ;;; merror ;;; Ignore this, for now (element merror (make math-sequence (process-children-trim))) ;;; mpadded ;;; Hmmm (element mpadded (make math-sequence (process-children-trim))) ;;; mphantom ;; do it in white: not really the same as invisible ;; but not sure if there is an easy general way to access ;; background colour. (element mphantom (make math-sequence color: (rgb-color 1 1 1) (process-children-trim))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mfenced ;;; Doesn't do separators for now. (element mfenced (make fence (if (attribute-string "open") (make math-sequence label: 'open (literal (attribute-string "open"))) (empty-sosofo)) (if (attribute-string "close") (make math-sequence label: 'close (literal (attribute-string "close"))) (empty-sosofo)) (make math-sequence (process-children-trim)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Superscripts and subscripts ;;; msup (element msup (make script (let ((nl (children(current-node)))) (sosofo-append (make math-sequence (process-node-list (node-list-first nl))) (make math-sequence label: 'post-sup (process-node-list (node-list-rest nl))))))) ;;; msub (element msub (make script (let ((nl (children(current-node)))) (sosofo-append (make math-sequence (process-node-list (node-list-first nl))) (make math-sequence label: 'post-sub (process-node-list (node-list-rest nl))))))) ;;; msubsup (element msubsup (make script (let* ((nl (children(current-node))) (nlr (node-list-rest nl))) (sosofo-append (make math-sequence (process-node-list (node-list-first nl))) (make math-sequence label: 'post-sub (process-node-list (node-list-first nlr))) (make math-sequence label: 'post-sup (process-node-list (node-list-rest nlr))))))) ;;; mmultiscripts ;;; In order to get the scripts aligning with each other ;;; they all script an empty element (so ignore th esize of the base ;;; I wish I could measure things in DSSSL.... (element mmultiscripts (let* ((nl (children(current-node))) (base (node-list-first nl)) (nlr (node-list-rest nl))) (process-multi-scripts base nlr #t (empty-sosofo) (empty-sosofo)))) ;;; while flag is true scoop up the scripts into the fourth argument ;;; then when you see multiscripts switch the flag so then start collecting ;;; in the third argument. Finally when rest is empty, stuff the scripts ;;; around the base. (define (process-multi-scripts base rest flag left right ) (if (node-list-empty? rest) (sosofo-append left (make math-sequence (process-node-list base)) right) ; else (if (equal? "mprescripts" (gi (node-list-first rest))) (process-multi-scripts base (node-list-rest rest) #f left right) (if flag (process-multi-scripts base (node-list-rest (node-list-rest rest)) flag left (sosofo-append right (make script (make math-sequence label: 'post-sub (process-node-list (node-list-first rest))) (make math-sequence label: 'post-sup (process-node-list (node-list-first (node-list-rest rest))))))) ; else (process-multi-scripts base (node-list-rest (node-list-rest rest)) flag (sosofo-append left (make script (make math-sequence label: 'post-sub (process-node-list (node-list-first rest))) (make math-sequence label: 'post-sup (process-node-list (node-list-first (node-list-rest rest)))))) right))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; none/ ;;; Not the hardest thing to implement (element none (empty-sosofo)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Under and over bars. ;;; These don't work yet. (element munder (make math-sequence (process-children-trim))) (element mover (make math-sequence (process-children-trim))) (element munderover (make math-sequence (process-children-trim))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Operator dictionary ;;; This is just a small version, while I test various implementations. ;;; First put back the indirection that TeX as but that MathML omitted. ;;; Need the default lengths to refer to variables rather than explicit ;;; lengths, so that you can change them all together. ;;; Apart from the fact that it isn't implemented, there arelots of other ;;; problems with this operator dictionay concept. ;;; (mathml problem) As noted above the recommendation gives explicit lengths. ;;; (mathml problem) As the recommendation gives fixed (as opposed to ;;; variable/stretchy) lengths. ;;; (dsssl problem) Full support of stretch operators would require an ;;; extended dsssl flow object (or extended semantics ;;; for the stretchy character characteristic) to support ;;; `mid' fences. ;;; (define %zskip 0em) (define %smallskip .05555em) (define %medskip .16666em) (define %bigskip .16666em) (define mathml-op-dict '( ("+" ("prefix". ((lspace . %zskip) (rspace . %bigskip))) ("infix" . ((lspace . %medskip) (rspace . %medskip)))) ("*=" ("infix" . ((lspace . %bigskip)(rspace . %bigskip)))) ("(" ("prefix" . ((fence . #t )(stretchy . #t)(lspace . %zskip)(rspace . %zskip)))) (")" ("postfix" .((fence . #t )(stretchy . #t)(lspace . %zskip)(rspace . %zskip)))) )) ;;; Helper function, just trims spaces from strings, actually ;;; zaps all space. needed as mo doesn't use process-children-trim. (define (string-nospace s) (let ((l (string-length s))) (let loop ((i 0)) (if (= i l) "" (let (( x (string-ref s i))) (if (equal? #\space x) (loop (+ i 1)) (string-append (string x) (loop (+ i 1))))))))) ;;; mo ;;; This current version tries to implement the defaulting ;;; of the various attributes. Although currently ;;; It doesn't actually use th eattributes once it has got the ;;; values. (element mo (let* ;; First get the name of the operator ;; and the surrounding node list which will be dealt with specially ;; if it is mrow (or more correctly should be mrow-like) ((nm (string-append(string-nospace (data (current-node))))) (pnt (parent)) ;; An explicit form attribute (or #f) (form1 (attribute-string "form")) ;; Look up the name in the operator dictionary, which will return ;; another association list, for looking up the form [if the operator ;; is in the dictionary]. (p (assoc nm mathml-op-dict)) (form (if form1 (if p ;; If a form was specified, and the operator is in the dictionary ;; look up the list of defaults. If it isn't in the dictionary ;; with this form just make up a list just consisting of the form. (or (assoc form1 (cdr p)) (list form1)) (list form1 )) ;; Otherwise if a form was not specified, look up how many entries ;; in the operator dictionary for this operator. (let* ((dict-entries (if p (length (cdr p)) 0))) (if (= 0 dict-entries) ;; If there are none, the operator is infix. (list "infix" ) (if (= 1 dict-entries) ;; If there is one, return that. (car (cdr p)) ;; If there is more than one, look where we are in the parent list ;; to decide which one to use. (let ((d (assoc (if (string=? "mrow" (gi pnt)) (let ((l (node-list-length (children pnt))) (n (absolute-child-number (current-node)))) (if (> l 1) (if (= n 1) "prefix" (if (= n l) "postfix" "infix")) "infix")) "infix") (cdr p)))) (if d d (car (cdr p)))) ))) ; let* )) ; form ;; Fence, from an attribute or out of the dictionary (fence1 (attribute-string "fence")) (fence (&my-debug(if fence1 (string=? fence1 "true") (cdr (or (assoc 'fence (cdr form)) '( #t . #f)))))) ) ; end of let* settings ;; Having done all that work, ignore all the attributes and just process ;; the children. (make math-sequence (process-children-trim)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Helper function that just sticks a number of copies of a sosofo ;;; on to the current sosofo. Used to pad out grids. (define (repeat-sosofo n sos) (if (equal? n 0) (empty-sosofo) (sosofo-append sos (repeat-sosofo (- n 1) sos)))) ;;; mtable ;;; Spanning cells not supported as I need to use dsssl grid flow objects ;;; which don't span. Dsssl table flow objects do support spanning but they ;;; are display objects and can't be inlined so are no good for this. (element mtable ;; Preliminary pass through the table to count the number of columns (let ((cols (&my-debug(node-list-reduce (children(current-node)) (lambda (a b) (if (string=? "mtr" (gi b)) (max a (node-list-length (children b))) a)) 0)))) (make grid grid-n-columns: cols ;; Now main pass, making grid-cell flow object specifications. (node-list-reduce (children(current-node)) (lambda (a b) (if (string=? "mtr" (gi b)) (sosofo-append a (node-list-reduce (children b) (lambda (x y) (sosofo-append x (make grid-cell (process-node-list y)))) (empty-sosofo)) (repeat-sosofo (- cols (node-list-length (children b))) (make grid-cell (empty-sosofo)))) (sosofo-append a (make grid-cell (process-node-list b)) (repeat-sosofo (- cols 1) (make grid-cell (empty-sosofo)))))) (empty-sosofo))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; semantics ;;; Helper function to dig out a MathML-Presentation child ;;; if it exists. (define (get-presentation nl) (if (node-list-empty? nl) #f (if (and (string=? "annotation-xml" (gi (node-list-first nl))) (string=? "MathML-Presentation" (or (attribute-string "encoding" (node-list-first nl)) ""))) (children (node-list-first nl)) (get-presentation (node-list-rest nl))))) ;;; Typeset the body and ignore all annotations, unless there ;;; is an annotation-xml giving MathML-Presentation ;;; in which case use that and ignore everything else. (element semantics (let* ((nl (children (current-node)))) (process-node-list (or (get-presentation (node-list-rest nl)) (node-list-first nl))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Content MathML ;;; In contrast to Presentation forms, Content MathML has vary few ;;; elements defined in the dsssl, instead the apply element explitly ;;; processes its children and calls [allegedly] suitable functions. ;;; It would be nice to use the dsssl transformation language to explicitly ;;; map content forms to presentation, ;;; but the style language isn't available, so... ;;; Helper function dealing with bound variables on sums and products ;;; Checks for lowlimit child. (define (dobvar product-char-sosofo equal-char-sosofo b r) (let ((first (gi (node-list-first r)))) (cond ((string=? "lowlimit" first) (bvarl product-char-sosofo (sosofo-append b equal-char-sosofo (process-node-list (node-list-first r))) (node-list-rest r))) ((string=? "condition" first) (bvarl product-char-sosofo (process-node-list (node-list-first r)) (node-list-rest r))) (else (bvarl product-char-sosofo (empty-sosofo) r))))) ;; Second function, checks for uplimit (define (bvarl product-char-sosofo low r) (if (string=? "uplimit" (gi (node-list-first r))) (bvaru product-char-sosofo low (process-node-list (node-list-first r)) (node-list-rest r)) (bvaru product-char-sosofo low (empty-sosofo) r))) ;; third function, add the found limits to the sum or product character (define (bvaru product-char-sosofo low high r) (sosofo-append (make script (make math-sequence label: 'post-sub low) (make math-sequence label: 'post-sup high) product-char-sosofo) (process-node-list r))) ;;; General function to typeset a function with braced arguments. (define (apply-braced-fn fn args) (make math-sequence (sosofo-append (literal fn) (make fence (make math-sequence label: 'open (literal "(")) (make math-sequence label: 'close (literal ")")) (make math-sequence (process-node-list args)))))) ;;; product/ sum/ ;;; Look for bound vars, then call above helper function. (define (apply-product product-char-sosofo equal-char-sosofo args) (make math-sequence (let ((b (node-list-first args))) (if (string=? (gi b) "bvar") (dobvar product-char-sosofo equal-char-sosofo (process-node-list b) (node-list-rest args)) (sosofo-append product-char-sosofo (process-node-list b)))))) ;;; log/ ;;; Just needs to check for logbase/ (define (apply-log args) (make math-sequence (if (equal? "logbase" (gi (node-list-first args))) (sosofo-append (make script (sosofo-append (literal "log") (make math-sequence label: 'post-sub (process-node-list (node-list-first args))))) (apply-braced-fn "" (node-list-rest args))) (apply-braced-fn "log" args)))) ;;; root/ sqrt/ ;;; Checks for degree/ (define (apply-root args) (make radical (if (equal? "degree" (gi (node-list-first args))) (sosofo-append (make math-sequence (process-node-list (node-list-rest args))) (make math-sequence label: 'degree (process-node-list (node-list-first args)))) (make math-sequence (process-node-list args))))) ;;; forall/ exists/ ;;; Typeset any bound variables and conditions, ;;; separated by commas, then do a full stop and finally ;;; the body. (define (apply-forall op c) (make math-sequence (sosofo-append op (process-node-list (node-list-first c)) (node-list-reduce (node-list-rest c) (lambda (result n) (sosofo-append result (literal (if (or (equal? "bvar" (gi n)) (equal? "condition" (gi n))) "," ".")) (process-node-list n))) (empty-sosofo))))) ;;; int/ (define (apply-int args) (make math-sequence (let ((b (node-list-first args))) (if (string=? (gi b) "bvar") (dobvar (literal "\integral") (empty-sosofo) (empty-sosofo) (node-list-rest args)) (sosofo-append (literal "\integral") (process-node-list b)))))) ;;; power/ (define (apply-power args) (make script (sosofo-append (make math-sequence (process-node-list (node-list-first args))) (make math-sequence label: 'post-sup (process-node-list (node-list-rest args)))))) ;;; inverse/ (define (apply-inverse fname args) (make script (sosofo-append (make math-sequence (process-node-list args)) (make math-sequence label: 'post-sup (case fname (("inverse") (literal "-1")) (("transpose") (literal "t"))))))) ;;; over bars (don't work) (define (apply-over args) (make math-sequence (process-node-list args))) ;; fix! ;;; max/ and min/ (define (apply-max fname args) (make math-sequence (sosofo-append (make unmath (literal fname)) (do-set "{" "}" args)))) ;;; gcd/ (define (apply-gcd fname args) (make math-sequence (sosofo-append (make unmath (literal fname)) (do-set "(" ")" args)))) ;;; abs/ (define (apply-abs args) (make fence (make math-sequence label: 'open (literal "|")) (make math-sequence label: 'close (literal "|")) (make math-sequence (process-node-list args)))) ;;; diff/ ;;; Trick is to get hold of the degree. ;;; Recommendation is for ;;; d f ;;; --- (x) ;;; d x ;;; ;;; but I don't currently test for special functions which are ;;; just a single identifier like that, so currently you get ;;; d d^3 ;;; --- f(x) and --- f(x) ;;; d x d x^3 (define (apply-diff args) (sosofo-append (let* ((f (node-list-first (&my-debug2 args)))) (if (equal? "bvar" (gi f)) (let ((d (&my-debug2 (node-list-filter (lambda (n) (equal? "degree" (gi n))) (children f))))) (make fraction (sosofo-append (make math-sequence label: 'numerator (make script (sosofo-append (literal "d") (make math-sequence label: 'post-sup (process-node-list d)))))) (make math-sequence label: 'denominator (sosofo-append (literal "d") (make script (sosofo-append (process-node-list (node-list-filter (lambda (n) (not (equal? "degree" (gi n)))) (children f))) (make math-sequence label: 'post-sup (process-node-list d)))))))) (make fraction (sosofo-append (make math-sequence label: 'numerator (literal "d")) (make math-sequence label: 'denominator (sosofo-append (literal "d") (process-node-list f))))))) (process-node-list (node-list-rest args)))) ;;; partial differentiation ;;; ;;; Trick here is to amalgamate the degrees ;;; in the numerator: ;;; d^3 ;;; ---------- f(x) ;;; d^2 x d y ;;; ;; helper function that sets the bit of the denominator ;; corresponding to one bound variable. (define (do-one-partial nl) (let ((d (&my-debug2 (node-list-filter (lambda (n) (equal? "degree" (gi n))) (children nl))))) (make math-sequence label: 'denominator (sosofo-append (literal "d") (make script (sosofo-append (process-node-list (node-list-filter (lambda (n) (not (equal? "degree" (gi n)))) (children nl))) (make math-sequence label: 'post-sup (process-node-list d)))))))) ;;; partialdiff ;;; I suspect that I could make use of node-list-filter-by-gi ;;; from dblib here, but I only just noticed that function... (define (apply-partialdiff args) (sosofo-append (let* ((bvars (node-list-filter (lambda (n) (equal? "bvar" (gi n))) args)) ;; totald is the sum of all the degrees [with 1 being supplied ;; as a default in each case] There may be an easier way to get that. (totald (node-list-reduce bvars (lambda (result n) (+ result (or (string->number (string-nospace (data (node-list-filter (lambda (nn) (equal? "degree" (gi nn))) (children n))))) 1))) 0))) ;; Now it is easy, set a fraction with the partial and the bound vars ;; then put out the body. (make fraction (sosofo-append (make math-sequence label: 'numerator (make script (sosofo-append (literal "\partial-differential") (make math-sequence label: 'post-sup (literal (number->string totald)))))) (make math-sequence label: 'denominator (node-list-reduce bvars (lambda (result n) (sosofo-append ;; something is reversing the args, so I'll reverse them back (do-one-partial n) result)) (empty-sosofo)))))) (process-node-list (node-list-filter (lambda (n) (not (equal? "bvar" (gi n)))) args)))) ;;; apply ;;; This is the main switch for Content MathNL ;;; Mainly just a case statement on th egi of the first child ;;; with some fall back code in case the function argument isn't known. (element apply (let* ((nl (children (current-node))) (f (node-list-first nl)) (fname (&my-debug (gi f))) (args (&my-debug (node-list-rest nl)))) (case fname (("product") (apply-product (literal "\n-ary-product") (literal "=") args)) (("sum") (apply-product (literal "\n-ary-summation") (literal "=") args)) (("limit") (apply-product (literal "lim") (literal "\rightwards-arrow") args)) (("int") (apply-int args)) (("inverse" "transpose") (apply-inverse fname args)) (("power") (apply-power args)) (("forall") (apply-forall (literal "\for-all") args)) (("exists") (apply-forall (literal "\there-exists") args)) (("plus" "times" "minus" "union" "intersect" "compose" "divide" "rem") (do-nary-binop fname args)) (("mean" "conjugate") (apply-over args)) (("factorial") (sosofo-append (process-node-list args) (literal "!"))) (("root") (apply-root args)) (("sdev") (apply-braced-fn "\greek-small-letter-sigma" args)) (("median" "mode") (apply-braced-fn fname args)) (("max" "min") (apply-max fname args)) (("gcd") (apply-gcd fname args)) (("log") (apply-log args)) (("abs") (apply-abs args)) (("diff") (apply-diff args)) (("partialdiff") (apply-partialdiff args)) (("var") (make script (make math-sequence label: 'post-sup (literal "2")) (apply-braced-fn "\greek-small-letter-sigma" args))) (("transpose") (make script (make math-sequence label: 'post-sup (literal "t")) (process-node-list args))) (else (make math-sequence (sosofo-append (process-node-list f) (if (and (equal? 1 (&my-debug (node-list-length args))) (equal? "ci" (gi args))) (make math-sequence (process-node-list args)) (make fence (make math-sequence label: 'open (literal "(")) (make math-sequence label: 'close (literal ")")) (make math-sequence (process-node-list args)))))))))) ;;; reln ;;; relations are similar to apply. ;;; Currently there is a double test as this top level ;;; function bunches all binops together, then do-binary-reln ;;; tests again to separate them, perhaps not the best idea. (element reln (let* ((r (gi (node-list-first (children (current-node))))) (c(&my-debug (node-list-rest(children (current-node)))))) (case r (("neq" "implies" "in" "notin" "notsubset" "notprsubset" "tendsto") (do-binary-reln r c)) (("eq" "leq" "lt" "geq" "gt" "subset" "prsubset") (do-nary-reln r c))))) ;;; Typeset a binary infix relation (define (do-binary-reln r c) (sosofo-append (process-node-list (node-list-first c)) (literal (case r (("neq") "\not-equal-to") (("implies") "\leftwards-double-arrow") (("in") "\element-of") (("notin") "\not-an-element-of") (("notsubset") "\not-a-subset-of") (("notprsubset") "PR\not-a-subset-of"); fix! (("tendsto") "\rightwards-arrow"))); fix for type attribute (process-node-list (node-list-rest c)))) ;;; Typeset a nary infix relation ;;; repeating the operator as many times as needed. (define (do-nary-reln r c) (let ((rs (literal (case r (("eq") "\equals-sign") (("leq") "\less-than-or-equal-to") (("lt") "\less-than-sign") (("geq") "\greater-than-or-equal-to") (("gt") "\greater-than-sign") (("subset") "\subset-of") (("prsubset") "PR\subset-of")))));fix! (sosofo-append (process-node-list (node-list-first c)) (node-list-reduce (node-list-rest c) (lambda (result n) (sosofo-append result rs (process-node-list n))) (empty-sosofo))))) ;;; typeset an nary operator, as for relations. (define (do-nary-binop op c) (let ((ops (literal (case op ((",") ",") (("plus") "\plus-sign") (("times") "") (("union") "\union") (("intersect") "\intersection") (("minus") "\minus-sign") (("divide") "\division-slash") (("rem") "mod") ;fix (("compose") "\U-2218") )))) (sosofo-append (process-node-list (node-list-first c)) (node-list-reduce (node-list-rest c) (lambda (result n) (sosofo-append result ops (process-node-list n))) (empty-sosofo))))) ;;;;;;;;;;;;;;;; ;;;; ident (element ident (make math-sequence (literal "id"))) ;;; trig ;;; Currently these done with th eelement declarations ;;; and the fallback case of apply typesetting the arguments. ;;; may need to change that. (define (do-sin sin) (make unmath font-posture: 'upright (literal sin))) (element sin (do-sin "sin")) (element cos (do-sin "cos")) (element tan (do-sin "tan")) (element sec (do-sin "sec")) (element csc (do-sin "csc")) (element cot (do-sin "cot")) (element sinh (do-sin "sinh")) (element cosh (do-sin "cosh")) (element tanh (do-sin "tanh")) (element sech (do-sin "sech")) (element csch (do-sin "csch")) (element coth (do-sin "coth")) (element arcsin (do-sin "arcsin")) (element arccos (do-sin "arccos")) (element arctan (do-sin "arctan")) ;;;; ;;; natural log and determinant are honourary trig functions. ;;; I should make det applied to an explicit table use | | rather ;;; than det ( ) I think. (element ln (do-sin "ln")) (element determinant (do-sin "det")) ;;;;;;;;;;; ;;; sets and lists (element set (do-set "{" "}" (children (current-node)))) (element list (do-set "[" "]" (children (current-node)))) (element vector (do-set "(" ")" (children (current-node)))) (element interval (case (attribute-string "closure" (current-node)) (("closed") (do-set "[" "]" (children (current-node)))) (("open") (do-set "(" ")" (children (current-node)))) (("open-closed") (do-set "(" "]" (children (current-node)))) (("closed-open") (do-set "[" ")" (children (current-node)))))) ;;; helper function for sets. ;;; Checks for two styles, comma separated explicit, ;;; or via conditions and bound vars. (define (do-set left right args) (make fence (make math-sequence label: 'open (literal left)) (make math-sequence label: 'close (literal right)) (make math-sequence (if (equal? "bvar" (gi (node-list-first (&my-debug2 args)))) (if (equal? 2 (node-list-length args)) ;; typeset bvar (sosofo-append (process-node-list (children (node-list-first args))) (literal "|") (process-node-list (children (node-list-rest args)))) ;; else dont (sosofo-append (process-node-list (node-list-rest(node-list-rest args))) (literal "|") (process-node-list (children (node-list-first (node-list-rest args)))))) ;; else stick in some commas (do-nary-binop "," args) )))) ;;;;;;; ;;; lambda [lamda according to Jade ?] (element lambda (sosofo-append (make math-sequence (literal "\greek-small-letter-lamda")) (do-nary-binop "," (node-list-filter (lambda (n) (equal? "bvar" (gi n))) (children (current-node)))) (literal ".") (process-node-list (&my-debug2(node-list-filter (lambda (n) (not (equal? "bvar" (gi n)))) (children (current-node))))))) ;;;;;;;;;;;;;;; ;;; cn ;;; what to do if you see a sep element for rationals.. (define (sep-rational top bottom) (make fraction (sosofo-append (make math-sequence label: 'numerator (process-node-list top)) (make math-sequence label: 'denominator (process-node-list bottom))))) ;;; and for complex cartesian (define (sep-complex-cartesian top bottom) (make math-sequence (sosofo-append (make math-sequence (process-node-list top)) (make math-sequence (literal "+")) (make math-sequence (process-node-list bottom)) (make math-sequence (literal "i"))))) ;;; and polar (define (sep-complex-polar top bottom) (make math-sequence (sosofo-append (make math-sequence (literal "Polar")) (make fence (sosofo-append (make math-sequence label: 'open (literal "(")) (make math-sequence label: 'close (literal ")")) (sosofo-append (make math-sequence (process-node-list top)) (make math-sequence (literal ",")) (make math-sequence (process-node-list bottom)))))))) ;;; Function to collect node list before and after sep element ;;; then finally call one of the above functions to typeset the ;;; two halves of the number. (define (do-sep fn flag top bottom args) (if (equal? 0 (node-list-length args)); why can't I use null (fn top bottom) (if (equal? "sep" (gi (node-list-first args))) (do-sep fn #f top bottom (node-list-rest args)) (if flag (do-sep fn flag (node-list top (node-list-first args)) bottom (node-list-rest args)) (do-sep fn flag top (node-list bottom (node-list-first args)) (node-list-rest args)))))) ;;; cn ;;; subscript with the base unless it is 10, or call one of the above functions ;;; to start looking for sep element. (element cn (case (or (attribute-string "type" (current-node)) "real") (("real" "constant") (make math-sequence (process-node-list (children (current-node))))) (("integer") (if (equal? "10" (attribute-string "base" (current-node))) (make math-sequence (process-node-list (children (current-node)))) (make script (sosofo-append (make math-sequence (process-node-list (children (current-node)))) (make math-sequence label: 'post-sub (literal (attribute-string "base" (current-node)))))))) (("rational") (do-sep sep-rational #t (empty-node-list) (empty-node-list) (children (current-node)))) (("complex-cartesian") (do-sep sep-complex-cartesian #t (empty-node-list) (empty-node-list) (children (current-node)))) (("complex-polar") (do-sep sep-complex-polar #t (empty-node-list) (empty-node-list) (children (current-node)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ought to share code with mtable, probably (element matrix (let* ((c (&my-debug (children (current-node)))) (n (&my-debug (node-list-length (children (node-list-first c)))))) (make fence (make math-sequence label: 'open (literal "(")) (make math-sequence label: 'close (literal ")")) (make grid grid-n-columns: n (node-list-reduce c (lambda (a b) (sosofo-append a (node-list-reduce (children b) (lambda (x y) (sosofo-append x (make grid-cell (process-node-list y)))) (empty-sosofo)))) (empty-sosofo)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;