MathCAD 11b / MathCAD 11 / diffeq

; EINFO points to the block closer tree node

( (create-pde-solver-call $EINFO $args $constraints
$res)
(#) (create-pde-call-no-fname $EINFO $args $constraints
$r1) (!)
(postprocess $r1 $res) )

( (create-pde-solver-call $EINFO $args $constraints
$res)
(#) (create-pde-call $EINFO $args $constraints
$r1) (!)
(postprocess $r1 $res) )


; This clause is here to accomodate bug 020826-170504, which says
; that you can use a PDE block without specifying a function name.
( (create-pde-call-no-fname $EINFO ($space-var $space-endpoints $time-var | $r)
$constraints
$res)
(is-identifier $space-var)
(is-identifier $time-var)
(id $space-endpoints (-mkMatrix 2 1 | $r1))
(#)
(infer-function-name $space-var $time-var $constraints
$fname)
(!)
(#)
(create-pde-call $EINFO ($fname $space-var $space-endpoints $time-var | $r)
$constraints
$res)
(!) )

( (infer-function-name $space-var $time-var $constraints
$fname)
(#)
(map-accum-rec &is-pderiv-%-5 ($space-var $time-var) () $constraints
$res $accum-end)
(!)
(id $accum-end ($fname | $r)) )

( (is-pderiv ($space-var $time-var) $accum $expr
0 ($fname | $accum))
(pderiv $fname $time-var $order $args $expr)
(> $order 0) )

( (is-pderiv ($space-var $time-var) $accum $expr
0 ($fname | $accum))
(pderiv $fname $space-var $order $args $expr)
(> $order 0) )



( (create-pde-call $EINFO ($fmat $space-var | $r) $constraints
(-mkError2 @"PDESpatialVarMustBeId" $EINFO 2))
(not-identifier $space-var) )

( (create-pde-call $EINFO ($fmat $space-var $space-endpoints $time-var | $r)
$constraints
(-mkError2 @"PDETemporalVarMustBeId" $EINFO 4))
(not-identifier $time-var) )


( (create-pde-call $EINFO $args $constraints
(-mkError2 @"too few arguments" $EINFO 0))
(length $args $n)
(< $n 5) )


( (create-pde-call $EINFO ($fmat $space-var $space-endpoints $time-var | $r)
$constraints
(-mkError2 @"PDE2ndOrderTimeNotAllowed" $EINFO 0))
(has-2-order-time ($space-var $time-var) $constraints
1) )

( (create-pde-call $EINFO ($fmat $space-var $space-endpoints $time-var | $r)
$constraints
(-mkError2 @"PDE3rdOrderSpaceNotAllowed" $EINFO 0))
(has-3-order-space ($space-var $time-var) $constraints
1) )

( (create-pde-call $EINFO $args $constraints
$res)
(#)
(preprocess-pde $EINFO $args $constraints
($fnames $space-var $leftb $rightb
$time-var $btime $etime
$eqns $num-spatial $num-temporal))
(filter &is-dirichlet-bc-%-3 ($fnames $space-var $time-var) $eqns
$dirichlet-bc $r1)
(filter &is-neumann-bc-%-3 ($fnames $space-var $time-var) $r1
$neumann-bc $r2)
(filter &is-init-c-%-3 ($fnames $space-var $btime) $r2
$init-c $r3)
(make-permutation-func $fnames
$sfnames $perm-func)
(length $fnames $num-func)
(!)
(filter &is-pde-%-3 ($fnames $space-var $time-var) $r3
$pdes $r4)
(filter &is-pae-%-3 ($space-var) $r4
$paes $r5)
(filter &is-coae-%-3 () $r5
$coaes ())
(#)
(make-coae-bindings
$fnames $space-var $time-var $num-spatial $leftb $rightb $coaes
$dirichlet-bc $neumann-bc
$coae-bindings $new-dbc $new-vbc)
(!)
(#)
(nsort $pdes &compare-first-%-2
$pdes-sorted)
(nsort $init-c &compare-first-%-2
$init-c-sorted)
(nsort $new-dbc &compare-first-%-2
$dirichlet-bc-sorted)
(nsort $new-vbc &compare-first-%-2
$neumann-bc-sorted)
(!)
(create-pdesolve-call $EINFO $sfnames $dirichlet-bc-sorted
$neumann-bc-sorted $init-c-sorted
$pdes-sorted $paes
$leftb $rightb $btime $etime
$num-spatial $num-temporal
$space-var $time-var
$pde-call)
(make-pde-interp ($perm-func $pde-call) $num-func
$leftb $rightb $btime $etime
$pde-interp)
(id $res (let* $coae-bindings
$pde-interp)) )


( (preprocess-pde $EINFO ($fmat $space-var (-mkMatrix 2 1 $leftb $rightb)
$time-var (-mkMatrix 2 1 $btime $etime)
| $opt-args)
$constraints
($fnames $space-var $leftb $rightb $time-var $btime $etime
$eqns | $popt-args))
(get-fnames $fmat $fnames)
(preprocess-constraints $constraints $eqns)
(preprocess-opt-args $EINFO $opt-args
$popt-args) )



( (get-fnames (-mkMatrix $n 1 | $fnames) $fnames) )
( (get-fnames $x ($x)) )

; Optionally, the number of spatial and temporal discretization
; points can be specified
( (preprocess-opt-args $EINFO ()
($spatial $temporal))
(make-discr-func 10 $EINFO 3 @"PDESpatialEndpointsMustBeReal"
$spatial)
(make-discr-func 100 $EINFO 5 @"PDETemporalEndpointsMustBeReal"
$temporal) )

( (preprocess-opt-args $EINFO ($nspace)
($spatial $temporal))
(make-discr-const $nspace $spatial)
(make-discr-func 100 $EINFO 5 @"PDETemporalEndpointsMustBeReal"
$temporal) )

( (preprocess-opt-args $EINFO ($nspace $ntime)
($spatial $temporal))
(make-discr-const $nspace $spatial)
(make-discr-const $ntime $temporal) )

( (preprocess-opt-args $EINFO ($nspace $ntime | $r)
((-mkError2 @"too many arguments" $EINFO 0) 0)) )

( (make-discr-func $n $EINFO $param_no $message
(-lambda (a b)
(trunc (-mult $n (-abs (-sub $ca $cb))))))
(make-check-real $EINFO $param_no $message a
$ca)
(make-check-real $EINFO $param_no $message b
$cb) )

( (make-discr-const $n
(-lambda (a b) $n)) )

( (make-check-real $EINFO $param_no $message $x
(if (and (IsScalar $x)
(-EQUALS (Im $x) 0))
$x
(-mkError2 $message $EINFO $param_no))) )




( (is-dirichlet-bc ($fnames $space-var $time-var)
(-EQUALS ($fname $pt $time-var) $expr)
($fname $pt $expr))
(nth-rev $n $fnames $fname)
(!= $pt $space-var)
; make sure that the function names don't occur on the right-hand side:
(#) (map-collect &has-%-3 $fnames $expr ()
$occurrences) (!)
(id $occurrences ()) )

( (is-neumann-bc ($fnames $space-var $time-var) (-EQUALS ($fx $pt $time-var)
$expr)
($fname $pt $expr))
(nth-rev $n $fnames $fname)
(count-partial $fx $fname $space-var 1)
(!= $pt $space-var)
; make sure that the function names don't occur on the right-hand side:
(#) (map-collect &has-%-3 $fnames $expr ()
$occurrences) (!)
(id $occurrences ()) )

( (is-init-c ($fnames $space-var $btime) (-EQUALS ($fname $space-var $pt)
$expr)
($fname $pt $expr))
(nth-rev $n $fnames $fname) )


( (is-pde ($fnames $space-var $time-var) $expr
$res)
(find-first &is-pde1-%-3 ($expr $space-var $time-var) $fnames
$res) )

( (is-pde1 ($expr $space-var $time-var) $fname
($fname $res))
(make-pderiv $fname $time-var 1 ($space-var $time-var)
$pd)
(solve $pd $expr $res) )

; helper for is-pae below
( (hasvar $var $var $var) )

( (is-pae ($space-var) (-EQUALS $lhs $rhs)
(-sub $lhs $rhs))
(#) (find-sub &hasvar-%-3 $space-var ($lhs $rhs)
$var) (!)
(id $var $space-var) )

( (has-2-order-time ($space-var $time-var) $expr
1)
(#)
(map-accum-rec &is-2-order-time-%-5 ($space-var $time-var) () $expr
$res $accum-end)
(!)
(id $accum-end (1 | $r)) )

( (is-2-order-time ($space-var $time-var) $accum $expr
0 (1 | $accum))
(pderiv $fname $time-var $order $args $expr)
(> $order 1) )


( (has-3-order-space ($space-var $time-var) $expr
1)
(#)
(map-accum-rec &is-3-order-space-%-5 ($space-var $time-var) () $expr
$res $accum-end)
(!)
(id $accum-end (1 | $r)) )

( (is-3-order-space ($space-var $time-var) $accum $expr
0 (1 | $accum))
(pderiv $fname $space-var $order $args $expr)
(> $order 2) )


; This predicate assumes that the PAEs have been filtered out
; Nutshell difference between a PAE and a COAE: the spatial
; variable appears explicitly in a PAE.
( (is-coae () (-EQUALS $lhs $rhs)
(-sub $lhs $rhs)) )

( (create-pdesolve-call $EINFO $fnames $dirichlet-bc $neumann-bc
$init-c $pdes $paes
$leftb $rightb $btime $etime
$num-spatial $num-temporal
$space-var $time-var
(and $check1
$check2
$dbc-check
$vbc-check
(-pdesolve $leftb $rightb
($num-spatial $leftb $rightb)
$btime $etime
($num-temporal $btime $etime)
$num-pde
$num-pae
$pdae-exist-2-order
$pfunc
$pinit-func
0 ; no coupled ODE
-num-coae ; num OAE
0 ; no couple vec for ODE
-coae-couple-vec ; couple vec for OAE
-coae-rhs ; rhs for ODE and OAE
(-coae-init $pinit-func) ; init. vec for ODE and OAE
$boundary-matrix
$bfunc-d-left
$bfunc-d-right
$bfunc-n-left
$bfunc-n-right)))
(#)
(length $pdes $num-pde)
(length $paes $num-pae)
(has-2-order $pdes $paes $space-var $pdae-exist-2-order)
(make-check1 $EINFO $num-pde $num-pae $fnames
$check1)
(!)
(#)
(make-pfunc $pdes $paes $fnames $space-var $time-var
$pfunc)
(!)
(#)
(make-pinit-func $init-c $btime $space-var
$pinit-func)
(make-check2 $init-c $fnames
$check2)
(!)
(#)
(fill-bc-entries $fnames $dirichlet-bc
$dbc-filled)
(make-bc-check $leftb $rightb $dirichlet-bc
$dbc-check)
(!)
(#)
(fill-bc-entries $fnames $neumann-bc
$vbc-filled)
(make-bc-check $leftb $rightb $neumann-bc
$vbc-check)
(!)
(#)
(make-bc-matrix ($leftb $rightb) $dbc-filled $vbc-filled
$boundary-matrix)
(!)
(make-bc-lambda-func ($leftb $rightb) $time-var $dbc-filled $vbc-filled
($bfunc-d-left
$bfunc-d-right
$bfunc-n-left
$bfunc-n-right)) )



; Detect 2nd-order spatial derivatives

( (has-2-order $pdes $paes $space-var
$pdae-exist-2-order)
(find-sub &is-2-order-%-3 $space-var $pdes
$pdae-exist-2-order) )

( (has-2-order $pdes $paes $space-var
$pdae-exist-2-order)
(find-sub &is-2-order-%-3 $space-var $paes
$pdae-exist-2-order) )

( (has-2-order $pdes $paes $space-var
0) )

( (is-2-order $var $expr
1)
(pderiv $fname $var 2 $args $expr) )


; Make function for evaluating PDE and PAE right-hand sides

( (make-pfunc $pdes $paes $fnames $space-var $time-var
(-lambda ($space-var $time-var -u -ux -uxx -v)
(-mkMatrix $rows 1 | $rhs)))
(filter &nth-%-3 1 $pdes
$pde-rhs ())
(map-rec &pderiv-subs-%-3 ($fnames $space-var $time-var) $pde-rhs
$p1)
(map-rec &pderiv-subs-%-3 ($fnames $space-var $time-var) $paes
$p2)
(append ($p1 $p2) $rhs)
(length $rhs $rows) )

( (pderiv-subs ($fnames $space-var $time-var) $expr
(-SUBSCRIPT $vname ($index 0)))
(pderiv $fname $space-var $order ($space-var $time-var) $expr)
(nth-rev $index $fnames $fname)
(repeat "x" $order $xx)
(strcat "-u" $xx $vname) )


; Predicates for analyzing the COAE

( (make-coae-bindings
$fnames $space-var $time-var $num-spatial $leftb $rightb $coae
$old-dbc $old-vbc
$bindings $new-dbc $new-vbc)
(id $bindings
((-repeat (-lambda (x n)
(if (-EQUALS n 0)
(list)
(-cons x (-repeat x (-sub n 1))))))
(-n ($num-spatial $leftb $rightb))
(-discr-index (-lambda (-left -right x)
(round
(-mult (-sub -n 1)
(-div (-sub x -left)
(-sub -right -left))))))
(-coae (-mapcar
(-lambda (-pair)
(-cons
(-discr-index $leftb $rightb (-car -pair))
(-cdr -pair)))
(list | $coae-pairs)))
(-sorted (-sort-list (-lambda (-p1 -p2) (-lthan (-car -p1) (-car -p2)))
-coae))
(-coae-couple-vec (-list2vec (-mapcar -car -sorted)))
(-num-coae (length (-list2vec -sorted)))
(-coae-rhs (-lambda $args
(-list2vec (-mapcar
(-lambda (-pair)
((-cdr -pair) | $args))
-sorted))))
(-coae-init (-lambda (-pfunc)
(-list2vec (list | $coae-ic))))))
(map-accum &analyze-coae-%-5
($fnames $space-var $time-var)
(0 () () () $old-dbc $old-vbc)
$coae
$coae-pairs ($m $coae-ic-r $dbc-names $vbc-names $new-dbc $new-vbc))
(id $args ($time-var -u -ux -uxx -v))
(reverse $coae-ic-r $coae-ic) )



( (analyze-coae ($fnames $space-var $time-var) $accum $expr
(-cons $pt (-lambda ($time-var -u -ux -uxx -v) $rhs))
$new-accum)
(#)
(analyze-coae-points ($fnames $space-var $time-var) $expr
$points)
(make-all-eq-test $points @"PDEBadCOAE" $pt)
(do-coae-subs ($fnames $space-var $time-var) (0 $accum) $expr
$rhs (1 $new-accum))
(!) )

( (analyze-coae-points ($fnames $space-var $time-var) $expr
$points)
(map-collect &analyze-coae-pt-%-3 ($fnames $space-var $time-var) $expr ()
$points) )

( (analyze-coae-pt ($fnames $space-var $time-var) $expr
$pt)
(pderiv $fname $space-var $order ($pt $time-var) $expr)
(nth-rev $index $fnames $fname) )

( (do-coae-subs ($fnames $space-var $time-var) $accum $expr
$rhs $new-accum)
(map-accum-rec &coae-subs-dirichlet-%-5 ($fnames $space-var $time-var)
$accum $expr
$rhs $new-accum) )

( (do-coae-subs ($fnames $space-var $time-var) $accum $expr
$rhs $new-accum)
(map-accum-rec &coae-subs-neumann-%-5 ($fnames $space-var $time-var)
$accum $expr
$rhs $new-accum) )

( (coae-subs-dirichlet ($fnames $space-var $time-var)
($did-subs $accum) $expr
(-SUBSCRIPT $vname ($index 0))
($did-subs $accum))
(pderiv $fname $space-var $order ($pt $time-var) $expr)
(nth-rev $index $fnames $fname)
(repeat "x" $order $xx)
(strcat "-u" $xx $vname)
(dbc-subs-not-needed $did-subs $order) )

; okay to do above substitution in these cases:
( (dbc-subs-not-needed 1 $order) )
( (dbc-subs-not-needed 0 $order)
(!= $order 0) )

( (coae-subs-dirichlet ($fnames $space-var $time-var) (0 $accum) $expr
$vsubs (1 $new-accum))
(#)
(pderiv $fname $space-var $order ($pt $time-var) $expr)
(nth-rev $index $fnames $fname)
(id $order 0)
(id $init (-SUBSCRIPT (-pfunc $pt) ($index 0)))
(id $accum ($n $ic $dbc-names $vbc-names $dbc $vbc))
(member $fname $dbc-names $fres)
(!)
(id $fres ())
(id $new-accum ($m
($init | $ic)
($fname | $dbc-names)
$vbc-names
(($fname $pt $vsubs) | $dbc)
$vbc))
(id $vsubs (-SUBSCRIPT -v ($n 0)))
(+ $n 1 $m) )


( (coae-subs-neumann ($fnames $space-var $time-var)
($did-subs $accum) $expr
(-SUBSCRIPT $vname ($index 0))
($did-subs $accum))
(pderiv $fname $space-var $order ($pt $time-var) $expr)
(nth-rev $index $fnames $fname)
(repeat "x" $order $xx)
(strcat "-u" $xx $vname)
(vbc-subs-not-needed $did-subs $order) )

; okay to do above substitution in these cases:
( (vbc-subs-not-needed 1 $order) )
( (vbc-subs-not-needed 0 $order)
(!= $order 1) )

( (coae-subs-neumann ($fnames $space-var $time-var) (0 $accum) $expr
$vsubs (1 $new-accum))
(#)
(pderiv $fname $space-var $order ($pt $time-var) $expr)
(nth-rev $index $fnames $fname)
(id $order 1)
(id $init 0)
(id $accum ($n $ic $dbc-names $vbc-names $dbc $vbc))
(member $fname $vbc-names $fres)
(!)
(id $fres ())
(id $new-accum ($m
($init | $ic)
$dbc-names
($fname | $vbc-names)
$dbc
(($fname $pt $vsubs) | $vbc)))
(id $vsubs (-SUBSCRIPT -v ($n 0)))
(+ $n 1 $m) )

( (make-all-eq-test ($x) $err
$x) )

( (make-all-eq-test ($x | $r) $err
(if (-EQUALS $x $rest)
$x
(-mkError $err)))
(make-all-eq-test $r $err
$rest) )



; Make function for (checking and) evaluating initial conditions

( (make-pinit-func $init-c $btime $space-var
(-lambda ($space-var)
(-mkMatrix $rows 1 | $ic)))
(filter &make-ic-entry-%-3 $btime $init-c
$ic ())
(length $ic $rows) )

( (make-ic-entry $btime ($fname $pt $expr)
(if (-EQUALS $pt $btime)
$expr
(-mkError @"PDEICNotConsistentWithBlock"))) )


; pderiv predicate below isn't reversible, so...

( (make-pderiv $fname $var $order $args ($f | $args))
(repeat $var $order $sub)
(strcat $fname "." $tmp)
(strcat $tmp $sub $f) )

; pderiv -- predicate is true if last argument is a
; partial derivative of order $order with
; respect to $var.

( (pderiv $fname $var $order $args ($f | $args))
(count-partial $f $fname $var $order) )

; Recognizes literal subscripts as partial derivatives
( (count-partial $f $fname $var $order)
(count-partial-1 $f $fname $var $order) )

( (count-partial-1 $f $fname $var $order)
(last-char $f $var)
(strcat $f1 $var $f)
(count-partial-1 $f1 $fname $var $o1)
(+ $o1 1 $order) )

( (count-partial-1 $f $fname $var 0)
(last-char $f ".")
(strcat $fname "." $f) )

( (count-partial $f $f $var 0) )

; Filter -- splits a list into two lists (those
; that satisfy a predicate, and those that don't).

( (filter $pred $pred-args ($x | $r)
($res | $yes) $no)
($pred $pred-args $x
$res)
(filter $pred $pred-args $r
$yes $no) )

( (filter $pred $pred-args ($x | $r)
$yes ($x | $no))
(filter $pred $pred-args $r
$yes $no) )

( (filter $pred $pred-args ()
() ()) )



; Find the first element of a list which satisfies a
; given predicate

( (find-first $pred $pred-args ($x | $r)
$res)
($pred $pred-args $x
$res) )

( (find-first $pred $pred-args ($x | $r)
$res)
(find-first $pred $pred-args $r
$res) )


; Find the first subexpression which satisfies a
; given predicate

( (find-sub $pred $pred-args $x
$res)
($pred $pred-args $x
$res) )

( (find-sub $pred $pred-args ($x | $r)
$res)
(find-sub $pred $pred-args $x
$res) )

( (find-sub $pred $pred-args ($x | $r)
$res)
(find-sub $pred $pred-args $r
$res) )

; Map a given predicate down a list, recursively

( (map-rec $pred $pred-args ($x | $r)
($y | $s))
($pred $pred-args $x $y)
(map-rec $pred $pred-args $r
$s) )

( (map-rec $pred $pred-args ($x | $r)
($y | $s))
(map-rec $pred $pred-args $x
$y)
(map-rec $pred $pred-args $r
$s) )

( (map-rec $pred $pred-args $x $x) )

; Map a predicate down a list, recursively, collecting
; its results into a another list

( (map-collect $pred $pred-args ($x | $r) $accum
$s)
(#) ($pred $pred-args $x $y) (!)
(#) (map-collect $pred $pred-args $r ($y | $accum)
$s) (!) )

( (map-collect $pred $pred-args ($x | $r) $accum
$s)
(#) (map-collect $pred $pred-args $x $accum
$s1) (!)
(#) (map-collect $pred $pred-args $r $s1
$s) (!) )

( (map-collect $pred $pred-args $x $accum
$accum) )


; Map a predicate down a list, maintaining an accumulator
; which is passed to it each time
; (It's assumed that the predicate never fails)

( (map-accum $pred $pred-args $accum-start ($x | $r)
($y | $s) $accum-end)
($pred $pred-args $accum-start $x
$y $accum-next)
(map-accum $pred $pred-args $accum-next $r
$s $accum-end) )

( (map-accum $pred $pred-args $accum-start ()
() $accum-start) )

; For testing map-accum:
( (counter () $n $x
$x $m)
(+ $n 1 $m) )

; Like map-accum, but walks recursively down sublists

( (map-accum-rec $pred $pred-args $accum-start ($x | $r)
($y | $s) $accum-end)
($pred $pred-args $accum-start $x
$y $accum-next)
(map-accum-rec $pred $pred-args $accum-next $r
$s $accum-end) )

( (map-accum-rec $pred $pred-args $accum-start ($x | $r)
($y | $s) $accum-end)
(map-accum-rec $pred $pred-args $accum-start $x
$y $accum-next)
(map-accum-rec $pred $pred-args $accum-next $r
$s $accum-end) )

( (map-accum-rec $pred $pred-args $accum-start $x
$x $accum-start) )

; For testing map-accum-rec:
( (count-str () $n $x
$x $m)
(+ $n 1 $m)
(!= $x "") )

; $lst should contain a list of three-element lists, like so:
; ((<function-name> <spatial point> <expression>)
; (<function-name> <spatial point> <expression>)
; ... )

( (fill-bc-entries ($f | $fnames) (($f $pt1 $expr1) ($f $pt2 $expr2) | $rest)
(($f ($pt1 $expr1) ($pt2 $expr2)) | $frest))
(fill-bc-entries $fnames $rest $frest) )

( (fill-bc-entries ($f | $fnames) (($f $pt1 $expr1) | $rest)
(($f ($pt1 $expr1) -NONE) | $frest))
(fill-bc-entries $fnames $rest $frest) )

( (fill-bc-entries ($f | $fnames) $rest
(($f -NONE -NONE) | $frest))
(fill-bc-entries $fnames $rest $frest) )

( (fill-bc-entries () ()
()) )


; Create a lambda that generates entries for the boundary-condition
; matrix

( (make-bc-matrix ($leftb $rightb) $dbc-triples $vbc-triples
(-mkMatrix $rows 2 | $entries))
(zip &make-bc-matrix-entry-%-4 ($leftb $rightb)
$dbc-triples $vbc-triples
$pairs)
(append $pairs $entries)
(length $pairs $rows) )


( (make-bc-matrix-entry ($leftb $rightb) ($f $db1 $db2) ($f $vn1 $vn2)
($left $right))
(make-bct $leftb $db1 $db2 $vn1 $vn2
$left)
(make-bct $rightb $db1 $db2 $vn1 $vn2
$right) )

( (make-bct $pt $db1 $db2 $vn1 $vn2
(-plus 1 (-plus $db $vn)))
(make-bct1 1 $pt $db1 $db2
$db)
(make-bct1 2 $pt $vn1 $vn2
$vn) )

( (make-bct1 $val $pt -NONE -NONE
0) )

( (make-bct1 $val $pt ($pt1 $expr1) -NONE
(if (-EQUALS $pt $pt1)
$val
0)) )

( (make-bct1 $val $pt ($pt1 $expr1) ($pt2 $expr2)
$val) )


; Create the four functions which will
; be used at run-time to evaluate the boundary conditions

( (make-bc-lambda-func ($leftb $rightb) $time-var $dbc-triples $vbc-triples
($db-left $db-right
$vb-left $vb-right))
(make-bc-lam $leftb $time-var $dbc-triples
$db-left)
(make-bc-lam $rightb $time-var $dbc-triples
$db-right)
(make-bc-lam $leftb $time-var $vbc-triples
$vb-left)
(make-bc-lam $rightb $time-var $vbc-triples
$vb-right) )

( (make-bc-lam $pt $time-var $triples
(-lambda ($time-var -v)
(-list2vec (-append | $r))))
(filter &make-bc1-%-3 $pt $triples
$r ()) )

( (make-bc1 $pt ($f -NONE -NONE)
(list)) )

( (make-bc1 $pt ($f ($pt1 $expr1) -NONE)
(if (-EQUALS $pt $pt1)
(-cons $expr1 (list))
(list))) )

( (make-bc1 $pt ($f ($pt1 $expr1) ($pt2 $expr2))
(if (-EQUALS $pt $pt1)
(-cons $expr1 (list))
(-cons $expr2 (list)))) )

; Make various consistency checks for the PDE block


; Create a basic check: number of functions being solved for
; must match number of equations

( (make-check1 $EINFO $num-pde $num-pae $fnames
(or (-EQUALS $n $m)
(-mkError2 @"PDEBadNumEQ" $EINFO 1)))
(+ $num-pde $num-pae $n)
(length $fnames $m) )


; Another basic check: number of functions must match number
; of initial conditions
( (make-check2 $init-c $fnames
(or (-EQUALS $n $m)
(-mkError @"PDEBadNumInit")))
(length $init-c $n)
(length $fnames $m) )

; Make a check on the boundary conditions: check that there
; are at most two for each function, and that they actually
; are at the boundaries.
( (make-bc-check $leftb $rightb $triples
(and (and 1 | $at-most-2)
(and 1 | $at-boundaries)))
(make-at-most-2-check $triples
$at-most-2)
(filter &at-boundaries-%-3 ($leftb $rightb) $triples
$at-boundaries ()) )

( (make-at-most-2-check (($f | $a) ($f | $b) ($f | $c) | $r)
((-mkError @"PDETooManyBC") | $s))
(make-at-most-2-check $r $s) )

( (make-at-most-2-check ($x | $r)
$s)
(make-at-most-2-check $r $s) )

( (make-at-most-2-check () ()) )

( (at-boundaries ($leftb $rightb) ($f $pt $expr)
(or (-EQUALS $pt $leftb)
(-EQUALS $pt $rightb)
(-mkError @"PDEBCNotConsistentWithBlock"))) )


; Create interpolator lambdas

; special case: only one function
( (make-pde-interp $matlist 1 $leftb $rightb $btime $etime
(-let ((-matlist $matlist))
$lambda))
(make-pde-interp-lambdas 0 1 $leftb $rightb $btime $etime
($lambda)) )

( (make-pde-interp $matlist $n $leftb $rightb $btime $etime
(-let ((-matlist $matlist))
(-mkMatrix $n 1 | $lambdas)))
(make-pde-interp-lambdas 0 $n $leftb $rightb $btime $etime
$lambdas) )

( (make-pde-interp-lambdas $i $n $leftb $rightb $btime $etime
((-let ((-mi (-GetNth -matlist $i)))
(-lambda (-x -t)
(-pdeinterp $leftb $rightb $btime $etime
-mi -x -t)))
| $rest))
(< $i $n)
(+ $i 1 $m)
(make-pde-interp-lambdas $m $n $leftb $rightb $btime $etime
$rest) )

( (make-pde-interp-lambdas $i $n $leftb $rightb $btime $etime
()) )

( (make-permutation-func $fnames
$sorted-fnames (-lambda (-lst)
(apply (-lambda $sorted-fnames
(list | $fnames))
-lst)))
(nsort $fnames &<-%-2 $sorted-fnames) )


; Not a PDE

( (create-ode-solver-call $EINFO ($meth-num $interp-num $R $TREE
$fnames $ivar $endpt | $opt)
$constraints
(-mkError @"non-scalar value"))
(not-identifier $ivar) )

( (create-ode-solver-call $EINFO $args $constraints
$res)

(#)
(preprocess $args $constraints
($soln-method $R $TREE $fnames $ivar $endpt $num-steps $eqns)) (!)
(#) (analyze-iconds $fnames $ivar $eqns
$iconds $rest-eqns) (!)
(analyze-eqns $fnames $ivar $rest-eqns
$derivs $alg)
; (validity-check $iconds $derivs $alg)
(#) (make-deriv-mat $fnames $derivs $alg
$dmat $omap $alg-f) (!)
(#) (perform-substitutions $ivar $omap $dmat
$new-dmat) (!)
(check-no-fail $new-dmat)
(length $omap $num-func)
(length $fnames $num-func)
(length $alg $nalg)
(make-ipoint $iconds $ipoint)
(make-ic-mat $iconds $alg-f $icmat)
(#) (make-ic-check $icmat $ivar $ipoint $alg
$ic-check) (!)
(#) (perform-substitutions $ivar $omap $ic-check
$new-ic-check) (!)
(make-sol-mat $fnames $omap $sol-mat)
(make-solver-call
$soln-method $R $TREE $icmat $endpt $num-steps $ivar $new-dmat $nalg
$solver-call)
(postprocess (let* ((-ipoint $ipoint)
(-ic-consistent $new-ic-check)
(-sol $solver-call))
$sol-mat)
$res)
)


( (preprocess ($meth-num
$interp-num
$R $TREE
(-mkMatrix $r $c | $fnames) $ivar $endpt | $opt) $constraints
($meth $R $TREE $fnames $ivar $endpt $num-steps $eqns))
(lookup-alist $meth-num ((0 rkfixed) (1 Rkadapt) (2 -radau))
$meth)
(preprocess-constraints $constraints $eqns)
(make-num-steps $endpt $opt
$num-steps $rest-opt) )


( (preprocess-constraints ((-lambda (-dummy) (-sub $a $b)) | $r)
((-EQUALS $a $b) | $s))
(preprocess-constraints $r $s) )

( (preprocess-constraints ((-sub $a $b) | $r)
((-EQUALS $a $b) | $s))
(preprocess-constraints $r $s) )

( (preprocess-constraints () ()) )


( (analyze-iconds $fnames $ivar ($eq | $eqns)
(($f $order $point $val) | $iconds) $rest)
(analyze-icond $fnames $ivar $eq ($f $order $point $val))
(analyze-iconds $fnames $ivar $eqns
$iconds $rest) )

( (analyze-iconds $fnames $ivar ($eq | $eqns)
$iconds ($eq | $rest))
(analyze-iconds $fnames $ivar $eqns
$iconds $rest) )

( (analyze-iconds $fnames $ivar ()
() ()) )


( (analyze-eqns $fnames $ivar ($eq | $eqns)
(($f $order $expr) | $derivs) $alg)
(analyze-eq $fnames $ivar $eq ($f $order $expr))
(analyze-eqns $fnames $ivar $eqns
$derivs $alg) )

; For now, anything which isn't a differential equation
; or an initial condition will be considered an algebraic
; constraint.
( (analyze-eqns $fnames $ivar ($eq | $eqns)
$derivs ($alg-rhs | $alg))
(#) (analyze-alg $eq $alg-rhs) (!)
(analyze-eqns $fnames $ivar $eqns
$derivs $alg) )

( (analyze-eqns $fnames $ivar ()
() ()) )


; This worked, but it turned out to be much more efficient
; to first extract the initial conditions...

; ( (analyze-block $fnames $ivar ($eq | $eqns)
; $iconds (($f $order $expr) | $derivs) $alg)
; (analyze-eq $fnames $ivar $eq ($f $order $expr))
; (analyze-block $fnames $ivar $eqns
; $iconds $derivs $alg) )
;
;
; ( (analyze-block $fnames $ivar ($eq | $eqns)
; (($f $order $point $val) | $iconds) $derivs $alg)
; (#) (analyze-icond $fnames $ivar $eq ($f $order $point $val)) (!)
; (analyze-block $fnames $ivar $eqns
; $iconds $derivs $alg) )
;
; ; For now, anything which isn't a differential equation
; ; or an initial condition will be considered an algebraic
; ; constraint.
; ( (analyze-block $fnames $ivar ($eq | $eqns)
; $iconds $derivs ($alg-rhs | $alg))
; (#) (analyze-alg $eq $alg-rhs) (!)
; (analyze-block $fnames $ivar $eqns
; $iconds $derivs $alg) )
;
; ( (analyze-block $fnames $ivar ()
; () () ()) )

( (analyze-icond ($f | $fnames) $ivar $eq ($f $order $point $val))
(analyze-icond-1 $f $ivar $eq ($f $order $point $val)) )

( (analyze-icond ($f | $fnames) $ivar $eq ($g $order $point $val))
(analyze-icond $fnames $ivar $eq ($g $order $point $val)) )

( (analyze-icond-1 $fname $ivar (-EQUALS $a $val) ($fname $order $point $val))
(deriv ($fname $ivar) $order $point $a)
(valid-icond-point $ivar $point) )

( (valid-icond-point $ivar ($x | $r)) )

( (valid-icond-point $ivar $pt)
(!= $ivar $pt) )

( (analyze-eq ($f | $fnames) $ivar $eq ($f $order $expr))
(analyze-eq-1 ($f $ivar) $eq ($f $order $expr)) )

( (analyze-eq ($f | $fnames) $ivar $eq ($g $order $expr))
(analyze-eq $fnames $ivar $eq ($g $order $expr)) )

( (analyze-eq-1 ($fname $ivar) $eq ($fname $order $expr))
(#)
(order ($fname $ivar) $eq $order)
(> $order 0)
(deriv ($fname $ivar) $order $ivar $d)
(solve $d $eq $expr)
(!)
)

( (analyze-alg (-EQUALS $a $b) (-sub $a $b)) )


( (validity-check $iconds $derivs $alg)
(length $iconds $n)
(length $alg $nalg)
(dsum $derivs $ds)
(+ $n $nalg $ds) )

( (dsum (($f $o $e) | $derivs) $res)
(dsum $derivs $s)
(+ $o $s $res) )

( (dsum () 0) )


( (make-ic-mat $iconds $alg-f (-mkMatrix $r 1 | $icexpr))
(sort-lists-2 $iconds $ics)
(move-to-end $alg-f $ics $ics1)
(lists-nth 3 $ics1 $icexpr)
(length $icexpr $r) )

( (mov-e-1 $f (($f $o $p $e) | $r)
$res)
(append ($r (($f $o $p $e))) $res) )

( (mov-e-1 $f (($g $o $p $e) | $r)
(($g $o $p $e) | $r1))
(mov-e-1 $f $r $r1) )

( (mov-e-1 $f ()
()) )

( (move-to-end ($f | $r) $ic
$res)
(mov-e-1 $f $ic $ic1)
(move-to-end $r $ic1 $res) )

( (move-to-end () $ic
$ic) )


( (make-ipoint $iconds
(if (and | $tests)
$pt
(-mkError @"ODEInconsistentInitCond")))
(lists-nth 2 $iconds ($pt | $pts))
(make-eq-tests $pt $pts $tests) )

( (make-eq-tests $pt ($x | $r) ((-EQUALS $pt $x) | $s))
(make-eq-tests $pt $r $s) )

( (make-eq-tests $pt () ()) )

( (make-num-steps $endpt ()
(trunc (-mult 10 (-abs (-sub $endpt -ipoint)))) ()) )

( (make-num-steps $endpt ($num-steps | $rest)
$num-steps $rest) )


; Make a consistency check for the algebraic constraints,
; if any.

; always succeed if no alg. constraints
( (make-ic-check $icmat $ivar $ipoint ()
1) )

( (make-ic-check $icmat $ivar $ipoint $alg
((-lambda (y $ivar) (or (and | $tests)
(-mkError @"ODEAlgInconsistentAtIP")))
$icmat $ipoint))
(make-alg-tests $alg $tests) )

( (make-alg-tests ($c | $r)
($tc | $tr) )
(make-alg-test $c $tc)
(make-alg-tests $r $tr) )

( (make-alg-tests () ()) )

( (make-alg-test $expr
(-lthan (-abs $expr) CTOL)) )

; Make the matrix of derivatives and algebraic constraints.
; Also return an assoc-list mapping each function to
; its position in the solution vector.
; The function names are needed because there may be
; algebraic constraints.
( (make-deriv-mat $fnames $derivs $alg
(-mkMatrix $r 1 | $all-expr) $omap $alg-f)
(#) (sort-lists-2 $derivs $ds) (!)
(#) (divide-nth 0 $ds $blocks) (!)
(#) (fill-blocks 0 $blocks $blocks-filled) (!)
(sort $fnames $fnames-sorted)
(make-omap 0 $fnames-sorted $blocks-filled $omap () $alg-f)
(append $blocks-filled $dsf)
(lists-nth 2 $dsf $dexpr)
(length $dexpr $ld)
(append ($dexpr $alg) $all-expr)
(length $all-expr $r)
)


( (fill-blocks $offset ($b | $r) ($b1 | $r1))
(fill-block $offset 1 $b $b1)
(length $b1 $len)
(+ $offset $len $new-offset)
(fill-blocks $new-offset $r $r1) )

( (fill-blocks $offset () ()) )


( (fill-block $offset $n ()
()) )

( (fill-block $offset $n (($f $n $expr) | $derivs)
(($f $n $expr) | $res))
(+ 1 $n $m)
(fill-block $offset $m $derivs $res) )

( (fill-block $offset $n (($f $n1 $e1) | $derivs)
(($f $n $e) | $res))
(> $n1 $n)
(+ $offset $n $noff)
(make-dmat-entry $f $noff $e)
(+ 1 $n $m)
(fill-block $offset $m (($f $n1 $e1) | $derivs) $res) )


( (make-omap $n ($f | $fnames) ($b | $blocks)
(($f ($n $bound)) | $res) () $alg-f)
(length $b $len)
(+ $len 1 $bound)
(+ $n $len $m)
(bfunc $b $f)
(make-omap $m $fnames $blocks
$res () $alg-f) )

( (make-omap $n ($g | $fnames) ($b | $blocks)
$res () $alg-f)
(append ($fnames ($g)) $nfnames)
(make-omap $n $nfnames ($b | $blocks)
$res () $alg-f) )

( (make-omap $n () ()
() () ()) )

( (make-omap $n ($f | $fnames) ()
$res () ($f | $fnames))
(make-omap $n () ()
$res ($f | $fnames) ()) )

; This clause handles algebraic constraints... they're
; all that should be left at this point
( (make-omap $n () ()
(($f ($n 1)) | $res) ($f | $alg) ())
(+ $n 1 $m)
(make-omap $m () ()
$res $alg ()) )



( (bfunc (($f | $r) | $r1) $f) )

( (make-dmat-entry $f $n (-SUBSCRIPT y ($n))) )


( (perform-substitutions $ivar $omap $d
(-SUBSCRIPT y ($m)))
(#) (deriv ($fname $ivar) $n $ivar $d)
(lookup-alist $fname $omap ($o $bound)) (!)
(> $bound $n)
(+ $o $n $m) )

( (perform-substitutions $ivar $omap $d
-FAIL)
(deriv ($fname $ivar) $n $ivar $d)
(lookup-alist $fname $omap ($o $bound)) )

( (perform-substitutions $ivar $omap (-lambda $bvs $body)
(-lambda $bvs $sbody))
(perform-substitutions $ivar $omap $body
$sbody) )

( (perform-substitutions $ivar $omap ($x | $r)
($x1 | $r1))
(#) (perform-substitutions $ivar $omap $x $x1) (!)
(#) (perform-substitutions $ivar $omap $r $r1) (!) )


( (perform-substitutions $ivar $omap $x
$x) )


( (check-no-fail ($x | $r))
(#) (check-no-fail $x) (!)
(#) (check-no-fail $r) (!) )

( (check-no-fail ()) )

( (check-no-fail $x)
(!= $x -FAIL) )

( (make-sol-mat $fnames $omap (-mkMatrix $r 1 | $s))
(length $fnames $r)
(make-sol-entries $fnames $omap $s) )


( (make-sol-entries ($f | $fnames) $omap ($s | $r))
(make-interp $f $omap $s)
(make-sol-entries $fnames $omap $r) )

( (make-sol-entries () $omap ()) )

( (make-interp $f $omap
(let* ((c0 (-colref -sol 0))
(cn (-colref -sol $n))
(-imat (lspline c0 cn)))
(-lambda (x) (interp -imat c0 cn x))))
(lookup-alist $f $omap ($o $_))
(+ $o 1 $n) )


; For the -radau solver, we ignore the number of steps, but
; do permit the number of algebraic constraints to be nonzero
( (make-solver-call -radau $R $TREE $icmat $endpt $numsteps $ivar $mat $nalg
(-radau $icmat
-ipoint
$endpt
0
$nalg
(-lambda ($ivar y) $mat)
TOL
(max 1000
(trunc (-mult 1000
(-abs (-sub $endpt -ipoint)))))
(-div (-abs (-sub $endpt -ipoint)) 1000))) )

; For any other solver, the number of algebraic constraints must
; be zero.
( (make-solver-call $soln-method $R $TREE $icmat $endpt $numsteps $ivar $mat 0
($soln-method $icmat
-ipoint
$endpt
$numsteps
(-lambda ($ivar y) $mat))) )

; If the number of algebraic constraints isn't zero, and we're
; not using the -radau method, we switch to the -radau method.
; This fixes bug 021106-094045.
( (make-solver-call
$soln-method $R $TREE $icmat $endpt $numsteps $ivar $mat $nalg
(-sequence ((-evalComponentS $R $R 4 $TREE 2) ; 4 for ODE msg
; 2 for -radau
$res)))
(make-solver-call -radau $R $TREE $icmat $endpt $numsteps $ivar $mat $nalg
$res) )


( (deriv ($fname $ivar) 0 $pt
($fname $pt)) )

( (deriv ($fname $ivar) 1 $pt
(-DERIVATIVE (-lambda ($ivar) ($fname $ivar)) $pt)) )

( (deriv ($fname $ivar) $n $pt
(NthDerivative (-lambda ($ivar) ($fname $ivar)) $n $pt))
(> $n 1) )

( (deriv ($fname $ivar) $n $pt
($fprime $pt))
(count-primes $fprime $n)
(strip-primes $fprime $fname) )

( (count-primes $fprime $n)
(strcat $f1 "'" $fprime)
(count-primes $f1 $m)
(+ $m 1 $n) )

( (count-primes $f 0) )

( (strip-primes $fprime $fname)
(strcat $f1 "'" $fprime)
(strip-primes $f1 $fname) )

( (strip-primes $f $f) )


( (order ($fname $ivar) $d $n)
(#)
(order-i ($fname $ivar) $d $n)
(!) )

( (order-i ($fname $ivar) $d $n)
(deriv ($fname $ivar) $n $ivar $d) )

( (order-i ($fname $ivar) ($a | $b) $n)
(order ($fname $ivar) $a $oa)
(order ($fname $ivar) $b $ob)
(max ($oa $ob) $n) )

( (order-i $e $x -1) )


( (max ($a $b) $a)
(> $a $b) )

( (max ($a $b) $b) )

; Solve for a subexpression, given an equality

( (solve $e (-EQUALS $a $b) $res)
(solve $e $a $b $res) )

; Given that two expressions are equal, solve
; for a subexpression of one of them.

( (solve $v $v1 $rhs $rhs)
(equiv $v $v1) )
( (solve $v $lhs $v1 $lhs)
(equiv $v $v1) )

( (equiv $v $v) )
( (equiv $v $w)
(deriv ($f $ivar) $n $pt $v)
(deriv ($f $ivar) $n $pt $w) )

( (solve $v (-plus $a $b) $rhs $res)
(solve $v $a (-sub $rhs $b) $res) )
( (solve $v (-plus $a $b) $rhs $res)
(solve $v $b (-sub $rhs $a) $res) )

( (solve $v (-sub $a $b) $rhs $res)
(solve $v $a (-plus $rhs $b) $res) )
( (solve $v (-sub $a $b) $rhs $res)
(solve $v $b (-sub $a $rhs) $res) )

( (solve $v (-mult $a $b) $rhs $res)
(solve $v $a (-div $rhs $b) $res) )
( (solve $v (-mult $a $b) $rhs $res)
(solve $v $b (-div $rhs $a) $res) )

( (solve $v (-div $a $b) $rhs $res)
(solve $v $a (-mult $rhs $b) $res) )
( (solve $v (-div $a $b) $rhs $res)
(solve $v $b (-div $a $rhs) $res) )

( (solve $v (-NEG $a) $rhs $res)
(solve $v $a (-NEG $rhs) $res) )

; Sorting

; New sort, now that the comparison predicate can be passed
; as an argument


( (nsort ($x | $r) $cmp
$res)
(#)
(nsplit $x ($x | $r) $cmp $less $equal $greater)
(nsort $less $cmp $a)
(nsort $greater $cmp $b)
(append ($a $equal $b) $res)
(!) )

( (nsort () $cmp ()) )


( (nsplit $x ($y | $r) $cmp ($y | $less) $equal $greater)
($cmp $y $x)
(nsplit $x $r $cmp $less $equal $greater) )

( (nsplit $x ($y | $r) $cmp $less $equal ($y | $greater))
($cmp $x $y)
(nsplit $x $r $cmp $less $equal $greater) )

( (nsplit $x ($y | $r) $cmp $less ($y | $equal) $greater)
(nsplit $x $r $cmp $less $equal $greater) )

( (nsplit $x () $cmp () () ()) )

; Zip

( (zip $pred $pred-args ($x | $r) ($y | $s)
($z | $rest ))
($pred $pred-args $x $y
$z)
(zip $pred $pred-args $r $s
$rest) )

( (zip $pred $pred-args () ()
()) )

; Old sort

( (sort ($x | $r) $res)
(#)
(split $x ($x | $r) $less $equal $greater)
(sort $less $a)
(sort $greater $b)
(append ($a $equal $b) $res)
(!) )

( (sort () ()) )


( (split $x ($y | $r) ($y | $less) $equal $greater)
(> $x $y)
(split $x $r $less $equal $greater) )

( (split $x ($y | $r) $less $equal ($y | $greater))
(> $y $x)
(split $x $r $less $equal $greater) )

( (split $x ($y | $r) $less ($y | $equal) $greater)
(split $x $r $less $equal $greater) )

( (split $x () () () ()) )


; Sort a list of lists lexicographically based on
; the first two elements of each list

( (sort-lists-2 ($x | $r) $res)
(split-lists-2 $x ($x | $r) $less $equal $greater)
(sort-lists-2 $less $a)
(sort-lists-2 $greater $b)
(append ($a $equal $b) $res) )

( (sort-lists-2 () ()) )


( (split-lists-2 $x ($y | $r) ($y | $less) $equal $greater)
(greater-lists-2 $x $y)
(split-lists-2 $x $r $less $equal $greater) )

( (split-lists-2 $x ($y | $r) $less $equal ($y | $greater))
(greater-lists-2 $y $x)
(split-lists-2 $x $r $less $equal $greater) )

( (split-lists-2 $x ($y | $r) $less ($y | $equal) $greater)
(split-lists-2 $x $r $less $equal $greater) )

( (split-lists-2 $x () () () ()) )

( (greater-lists-2 ($x $y1 | $r1) ($x $y2 | $r2) )
(> $y1 $y2) )

( (greater-lists-2 ($x1 $y1 | $r1) ($x2 $y2 | $r2) )
(> $x1 $x2) )



( (append2 ($x | $r) $l ($x | $s))
(append2 $r $l $s) )

( (append2 () $l $l) )

( (append ($l | $r) $res)
(append $r $r1)
(append2 $l $r1 $res) )

( (append () ()) )


; Find the nth element of a list

( (nth 0 ($x | $r) $x) )

( (nth $n ($x | $r) $y)
(+ $m 1 $n)
(nth $m $r $y) )

; The "nth" predicate above isn't reversible -- given
; a list and an item, you can't find the item's index.
; So...

( (nth-rev 0 ($x | $r) $x) )

( (nth-rev $n ($x | $r) $y)
(nth-rev $m $r $y)
(+ $m 1 $n) )


; Extract the $n-th element from each list in a list of lists
; and return the result
( (lists-nth $n ($l | $lists) ($x | $r))
(nth $n $l $x)
(lists-nth $n $lists $r) )

( (lists-nth $n () ()) )

( (length () 0) )
( (length ($x | $r) $n)
(length $r $m)
(+ $m 1 $n) )

( (lookup-alist $f (($f $o) | $r) $o) )

( (lookup-alist $f ($pair | $r) $o)
(lookup-alist $f $r $o) )

( (zip ($x | $r) ($y | $s) (($x $y) | $rs))
(zip $r $s $rs) )

( (zip () () ()) )


; Test for membership in a list
; Takes three arguments so as to be usable with map-collect

( (has ($x | $r) $x $x) )

( (has ($y | $r) $x $x)
(has $r $x $x) )

; Another way to test for membership in a list
; Result is () if element is not found

( (member $x ($x | $r) $x) )
( (member $y ($x | $r) $res)
(member $y $r $res) )
( (member $x () ()) )

; Reverse a list
( (reverse $x $y)
(r-help $x $x () $y $y ()) )

( (r-help $a ($x | $r) $t1 $b ($y | $s) $t2)
(r-help $a $r ($x | $t1) $b $s ($y | $t2)) )
( (r-help $a () $b $b () $a) )


; Divide a list of lists according to the nth
; element of each list
( (divide-nth $n ($l | $s)
$res)
(nth $n $l $x)
(divide-nth-i $x $n ($l | $s)
$res) )

( (divide-nth-i $x $n ($l | $s)
$res1)
(nth $n $l $x)
(divide-nth-i $x $n $s
$res)
(push-into-1st-block $l $res
$res1) )

( (divide-nth-i $x $n ($l | $s)
$res1)
(nth $n $l $y)
(divide-nth-i $y $n ($l | $s)
$res)
(push-empty-block $res
$res1) )

( (divide-nth-i $x $n ()
(())) )

( (push-into-1st-block $l ($ll | $s)
(($l | $ll) | $s)) )

( (push-empty-block $s
(() | $s)) )


; Repeat a certain string

( (repeat $str $n $res)
(> $n -1) ; important -- without this, backtracking into
; the "repeat" predicate could lead to an
; infinite loop
(+ $m 1 $n)
(repeat $str $m $r1)
(strcat $r1 $str $res) )

( (repeat $str 0 "") )


; Define a less-than predicate in terms of the built-in
; greather-than

( (< $x $y)
(> $y $x) )


; Compare two lists according to their first elements

( (compare-first ($x | $r) ($y | $s))
(< $x $y) )

; Postprocessing transforms standard Scheme constructs
; like let*, if, and, or, and so forth, into the
; idiosyncratic syntax required by the Mathcad compute
; engine.
;

; ( (postprocess $x $x) )

( (postprocess (if $cond $then $else) (-ifblock (($then1 $cond1)) $else1))
(postprocess $cond $cond1)
(postprocess $then $then1)
(postprocess $else $else1) )

( (postprocess (or $a) $a1)
(postprocess $a $a1) )

( (postprocess (or $a | $exprs) $res)
(postprocess (if $a $a (or | $exprs)) $res) )

( (postprocess (and $a) $a1)
(postprocess $a $a1) )

( (postprocess (and $a | $exprs) $res)
(postprocess (if $a (and | $exprs) 0) $res) )

( (postprocess (let* ($b | $bindings) $body)
(-let ($b1) $expr) )
(postprocess $b $b1)
(postprocess (let* $bindings $body) $expr) )

( (postprocess (let* () $body)
$expr)
(postprocess $body $expr) )

( (postprocess (-SUBSCRIPT $x $subs)
(-SUBSCRIPT $x1 $subs1))
(postprocess $x $x1)
(origin-protect $subs $subs1) )

; sometimes we want to ignore ORIGIN
( (postprocess (-subscript $x $subs)
(-SUBSCRIPT $x1 $subs1))
(postprocess $x $x1)
(postprocess-each $subs $subs1) )

( (postprocess (-colref $x $n)
(-colref $x1 $n1))
(postprocess $x $x1)
(origin-protect-1 $n $n1) )

( (origin-protect ($x | $r) ($y | $s))
(origin-protect-1 $x $y)
(origin-protect $r $s) )

( (origin-protect () ()) )

( (origin-protect-1 $x (-plus $y ORIGIN))
(postprocess $x $y) )

( (postprocess (-mkMatrix | $r) $res)
(postprocess-each $r $s)
(unit-protect $s $s1)
(unit-protect-1 (-mkMatrix | $s1) $res) )

( (postprocess (list | $args) (-mkListOfUV | $pargs))
(postprocess-each $args $pargs) )

( (postprocess ($x | $r) $res)
(postprocess-each ($x | $r) $res) )

( (postprocess $x $x) )

( (postprocess-each ($x | $r) ($x1 | $r1))
(postprocess $x $x1)
(postprocess-each $r $r1) )

( (postprocess-each () ()) )


( (unit-protect ($x | $r) ($y | $s))
(unit-protect-1 $x $y)
(unit-protect $r $s) )

( (unit-protect () ()) )

( (unit-protect-1 $x (-GetNth (-mkListOfUV $x) 0)) )



( (id $x $x) )


; ( (test $fnames $ivar $eqns
; $omap $dmat $new-dmat)
; (analyze-block $fnames $ivar $eqns
; $iconds $derivs $alg)
; (#) (make-deriv-mat $fnames $derivs $alg
; $dmat $omap $alg-f) (!)
; (perform-substitutions $ivar $omap $dmat
; $new-dmat) )
;
( (test2 $fnames $ivar $eqns
$blocks $blocks-filled $omap $alg-f $new-dmat)
(#) (analyze-iconds $fnames $ivar $eqns
$iconds $rest-eqns) (!)
(analyze-eqns $fnames $ivar $rest-eqns
$derivs $alg)

(validity-check $iconds $derivs $alg)

(#) (sort-lists-2 $derivs $ds) (!)
(#) (divide-nth 0 $ds $blocks) (!)
(#) (fill-blocks 0 $blocks $blocks-filled) (!)
(#) (sort $fnames $fnames-sorted) (!)
(#) (make-omap 0 $fnames-sorted $blocks-filled $omap () $alg-f) (!)
(#) (append $blocks-filled $dsf)
(lists-nth 2 $dsf $dexpr)
(length $dexpr $ld)
(append ($dexpr $alg) $all-expr)
(length $all-expr $r) (!)

(#) (perform-substitutions $ivar $omap (-mkMatrix $r 1 | $all-expr)
$new-dmat) (!)
(check-no-fail $new-dmat) )



--

; tests