#lang scheme/base
(require
"ring-sig.ss"
"vec-sig.ss"
"staged-number.ss"
"vec-list.ss"
"../tools.ss"
"staged-ops.ss"
)
(define/invoke (ring^ vec^) (staged-number@ vec-list@))
(define (tree-map fn)
(lambda (x)
(let sub ((x x))
(cond
((null? x) x)
((pair? x) (cons (sub (car x)) (sub (cdr x))))
(else (fn x))))))
(define pack
(tree-map
(lambda (x)
(if (symbol? x)
(make-variable (symbol->identifier x))
(make-number x)))))
(define unpack
(tree-map
(lambda (x)
(cond
((variable? x) (syntax->datum (variable-id x)))
((number? x) (number-value x))
(else (error 'unpack-unknown "~a" x))))))
(define (un-memoize expr)
(tree-map
(lambda (x)
(cond
((variable? expr)
(let ((e (variable->expr expr)))
(if e (un-memoize e) expr)))
(else expr)))))
(current-pack pack)
(current-unpack unpack)
(define (matrix sym) (list->mat (pack sym)))
(define a (matrix '((a 0) (0 b))))
(define b (matrix '((b 0) (d a))))
(require scheme/pretty)
(define (print-mat m)
(pretty-print (unpack (mat->list m))))
(define m
(matrix '(( 2 -1 0)
(-1 2 -1)
( 0 -1 2))))
(define (ctp:> a b)
(let ((na (->number a))
(nb (->number b)))
(or (and a b) (error 'ct:>))
(> na nb)))
(define (gauss-jordan m)
(mat-gauss-jordan 2-norm ctp:> m))
(define (mat-inv m)
(gauss-jordan (mat-cat-columns m (mat-one (mat-nb-rows m)))))
(define eq1
(matrix '(( 2 -1 0 a)
(-1 2 -1 b)
( 0 -1 2 c))))
(print-mat (gauss-jordan eq1))
(emit (pack '(X 123)))
(unpack (add (pack 'X) (pack 'X)))
(require (for-syntax scheme/base))
(define-syntax (id=? stx)
(syntax-case stx ()
((_ a b)
#`(quote #,(bound-identifier=? #'a #'b)))))