> This is a simple implementation of finding completely reduced Groebner
> Basis in scheme.

> You can find tutorials from:http://www.geocities.com/CapeCanaveral/Hall/3131/http://icm.mcs.kent....

> ;; Find Grobner Basis
> ;; License: "Don't blame me if the shuttle blows up during take-off."
> ;;

> ;; from lang.lang.scheme
> (define-syntax (define-macro stx)
>   (syntax-case stx ()
>    ((_ (macro . args) . body)
>     (syntax (define-macro macro (lambda args . body))))
>    ((_ macro transformer)
>     (syntax
>      (define-syntax (macro stx2)
>        (let ((v (syntax-object->datum stx2)))
>          (datum->syntax-object
>           ; we need the *identifier* of the macro call
>           ; (there is probably a smarter way of extracting that ...)
>           (syntax-case stx2 () ((name . more) (syntax name)))
>           (apply transformer (cdr v)))))))))

> ;; from lang.lang.scheme
> (define (make-queue)
>         (let ((queue '()))
>            (lambda (flag item)
>                    (cond ((eq? flag 'nq) (set! queue (append queue
> (list item))))
>                          ((eq? flag 'dq) (if (null? queue) nil
>                                              (let ((head (car queue)))
>                                                 (set! queue (cdr
> queue))
>                                                 head)))
>                          ((eq? flag 'head) (car queue))
>                          ((eq? flag 'size) (length queue))
>                          ((eq? flag 'mt) (eq? queue '()))))))
> (define (q-head queue) (queue 'head nil))
> (define (queue-size queue) (queue 'size nil))
> (define (enqueue queue item) (queue 'nq item))
> (define (dequeue queue)  (queue 'dq nil))
> (define (q-empty? queue) (queue 'mt nil))

> ;; I can't remember where I get this code from
> (define (contains? element list equal?)
>   (cond ((null? list) #f)
>         ((equal? element (car list)) #t)
>         (else (contains? element (cdr list) equal?))))
> (define (delete-duplicates-i list uniques equal?)
>   (cond ((null? list)
>          uniques)
>         ((contains? (car list) uniques equal?)
>          (delete-duplicates-i (cdr list) uniques equal?))
>         (else
>          (delete-duplicates-i (cdr list) (cons (car list) uniques)
> equal?))))
> (define (delete-duplicates list equal?)
>   (reverse (delete-duplicates-i list '() equal?)))

> ;;http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme-Z-H-1.html
> ;;
> (define amb-fail '*)
> (define initialize-amb-fail
>   (lambda ()
>     (set! amb-fail
>       (lambda ()
>         (error "amb tree exhausted")))))
> (define-macro amb
>   (lambda alts...
>     `(let ((+prev-amb-fail amb-fail))
>        (call/cc
>         (lambda (+sk)
>           ,@(map (lambda (alt)
>                    `(call/cc
>                      (lambda (+fk)
>                        (set! amb-fail
>                          (lambda ()
>                            (set! amb-fail +prev-amb-fail)
>                            (+fk 'fail)))
>                        (+sk ,alt))))
>                  alts...)
>           (+prev-amb-fail))))))
> (define number-between
>   (lambda (lo hi)
>     (let loop ((i lo))
>       (if (> i hi) (amb)
>           (amb i (loop (+ i 1)))))))
> (define assert
>   (lambda (pred)
>     (if (not pred) (amb))))
> (define-macro bag-of
>   (lambda (e)
>     `(let ((+prev-amb-fail amb-fail)
>            (+results '()))
>        (if (call/cc
>             (lambda (+k)
>               (set! amb-fail (lambda () (+k #f)))
>               (let ((+v ,e))
>                 (set! +results (cons +v +results))
>                 (+k #t))))
>            (amb-fail))
>        (set! amb-fail +prev-amb-fail)
>        (reverse! +results))))

> ;; /usr/share/slib/srfi-1.scm
> (define null-list? null?)
> (define (car+cdr pair) (values (car pair) (cdr pair)))
> (define (%cars+cdrs lists)
>   (call-with-current-continuation
>     (lambda (abort)
>       (let recur ((lists lists))
>         (if (pair? lists)
>             (call-with-values ; expanded a receive call
>               (lambda () (car+cdr lists))
>               (lambda (list other-lists)
>                 (if (null-list? list) (abort '() '()) ; LIST is empty
> -- bail out
>                   (call-with-values ; expanded a receive call
>                     (lambda () (car+cdr list))
>                     (lambda (a d)
>                       (call-with-values ; expanded a receive call
>                         (lambda () (recur other-lists))
>                         (lambda (cars cdrs)
>                           (values (cons a cars) (cons d cdrs)))))))))
>             (values '() '()))))))
> (define (map! f clist1 . lists)
>   (if (pair? lists)
>       (let lp ((clist1 clist1) (lists lists))
>         (if (not (null-list? clist1))
>             (call-with-values ; expanded a receive call
>               (lambda () (%cars+cdrs/no-test lists))
>               (lambda (heads tails)
>                 (set-car! clist1 (apply f (car clist1) heads))
>                 (lp (cdr clist1) tails)))))
>       ;; Fast path.
>       (pair-for-each (lambda (pair) (set-car! pair (f (car pair))))
> clist1))
>   clist1)
> (define (%cars+cdrs/no-test lists)
>   (let recur ((lists lists))
>     (if (pair? lists)
>       (call-with-values ; expanded a receive call
>         (lambda () (car+cdr lists))
>         (lambda (list other-lists)
>           (call-with-values ; expanded a receive call
>             (lambda () (car+cdr list))
>             (lambda (a d)
>               (call-with-values ; expanded a receive call
>                 (lambda () (recur other-lists))
>                 (lambda (cars cdrs)
>                   (values (cons a cars) (cons d cdrs))))))))
>       (values '() '()))))
> (define (pair-for-each proc clist1 . lists)
>   (if (pair? lists)
>       (let lp ((lists (cons clist1 lists)))
>         (let ((tails (%cdrs lists)))
>           (if (pair? tails)
>               (begin (apply proc lists)
>                      (lp tails)))))
>       ;; Fast path.
>       (let lp ((lis clist1))
>         (if (not (null-list? lis))
>             (let ((tail (cdr lis)))     ; Grab the cdr now,
>               (proc lis)                ; in case PROC SET-CDR!s LIS.
>               (lp tail))))))
> (define (%cdrs lists)
>   (call-with-current-continuation
>     (lambda (abort)
>       (let recur ((lists lists))
>         (if (pair? lists)
>             (let ((lis (car lists)))
>               (if (null-list? lis) (abort '())
>                   (cons (cdr lis) (recur (cdr lists)))))
>             '())))))
> (define (nreverse rev-it)
>   (cond ((null? rev-it) rev-it)
>         ((not (list? rev-it))
>          (error "nreverse: Not a list in arg1" rev-it))
>         (else (do ((reved '() rev-it)
>                    (rev-cdr (cdr rev-it) (cdr rev-cdr))
>                    (rev-it rev-it rev-cdr))
>                   ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-
> it)))))
> (define (any pred lis1 . lists)
>   (if (pair? lists)
>       ;; N-ary case
>       (call-with-values ; expanded a receive call
>         (lambda () (%cars+cdrs (cons lis1 lists)))
>         (lambda (heads tails)
>           (and (pair? heads)
>                (let lp ((heads heads) (tails tails))
>                  (call-with-values ; expanded a receive call
>                    (lambda () (%cars+cdrs tails))
>                    (lambda (next-heads next-tails)
>                      (if (pair? next-heads)
>                        (or (apply pred heads) (lp next-heads next-
> tails))
>                        (apply pred heads)))))))) ; Last PRED app is
> tail call.
>       ;; Fast path
>       (and (not (null-list? lis1))
>            (let lp ((head (car lis1)) (tail (cdr lis1)))
>              (if (null-list? tail)
>                  (pred head)            ; Last PRED app is tail call.
>                  (or (pred head) (lp (car tail) (cdr tail))))))))
> (define reverse! nreverse)

> ;; SICP
> (define true  #t)
> (define false #f)
> (define nil '())
> (define filter (lambda (predicate sequence)
>   (cond ((null? sequence) nil)
>         ((predicate (car sequence))
>          (cons (car sequence)
>                (filter predicate (cdr sequence))))
>         (else (filter predicate (cdr sequence))))))

> ;;http://www.cs.bgu.ac.il/~elhadad/scheme/merge.html
> (define (reverse-it ls acc)
>   (if (null? ls)
>       acc
>       (reverse-it (cdr ls) (cons (car ls) acc))))

> ;;http://www.cs.bgu.ac.il/~elhadad/scheme/insertion.html
> (define (insertion-sort ls . opt)
>   (let ((precedes? (if (null? opt) < (car opt))))
>     (define (insert new sorted)
>       (let loop ((rest sorted)
>                  (passed '()))
>         (cond ((null? rest)
>                (reverse-it passed (list new)))
>               ((precedes? new (car rest))
>                (reverse-it passed (cons new rest)))
>               (else
>                (loop (cdr rest)
>                      (cons (car rest) passed))))))
>     (let outer-loop ((remaining ls)
>                      (done '()))
>       (if (null? remaining)
>           done
>           (outer-loop (cdr remaining)
>                       (insert (car remaining) done))))))

> ;; The following codes were written by Naruto Canada
> ;; License: "Don't blame me if the shuttle blows up during take-off."
> ;;
> (define (PdivS p s)
>   (if (= s 0) 'ERROR
>       (map (lambda (t) (list (/ (car t) s) (cadr t))) p)
>   )
> )
> (define (divlead pred p)
>   (define s (LC pred p))
>   (PdivS p s)
> )
> (define (reduceg pred R)
>   (let* (
>          (s (length R))
>          (i (number-between 0 (- s 2)))
>          (j (number-between (+ i 1) (- s 1)))
>          (k (LM pred (list-ref R i)))
>          (l (LM pred (list-ref R j)))
>          (m (MdivM k l))
>          (n (MdivM l k))
>          (p (equal? 0 (length (filter negative? m))))
>          (q (equal? 0