Home     |     .Net Programming    |     cSharp Home    |     Sql Server Home    |     Javascript / Client Side Development     |     Ajax Programming

Ruby on Rails Development     |     Perl Programming     |     C Programming Language     |     C++ Programming     |     IT Jobs

Python Programming Language     |     Laptop Suggestions?    |     TCL Scripting     |     Fortran Programming     |     Scheme Programming Language


 
 
Cervo Technologies
The Right Source to Outsource

MS Dynamics CRM 3.0

Scheme Programming Language

Groebner Basis in Scheme


hi

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.edu/reports/1995/gb.pdf

;; 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 (length (filter negative? n))))
        )
        (if (and p q) -1
            (if p i (if q j -1)))
  )
)
(define (completely-reduced? pred G)
  (map (lambda (f) (NormalForm pred f (delete f G))) G))
(define (PcmpP p q) (null? (PaddP p (SmulP -1 q))))
(define (deleteP x ls)
  (define r '())
  (map (lambda (y) (if (not (PcmpP x y)) (set! r (cons y r)))) ls)
  (reverse r)
)
(define (Psetminus s1 s2)
 (define t s1)
 (map (lambda (x) (set! t (deleteP x t))) s2)
 t
)
(define (LC pred p)
  (car (list-ref p (get-lead pred p)))
)
(define (LCM x y)
  (if (or (null? x)
...

read more »

Cool --- so very cool.

OK ... so where do I put the dollar?

Thanks for sharing this - it really looks like a lot of
effort went into it and deserves a good look.

Mike

<narutocan@yahoo.ca> wrote in message

news:1178296110.844997.189660@n59g2000hsh.googlegroups.com...
| hi
|
| 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.edu/reports/1995/gb.pdf
|
| ;; 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))
|      
...

read more »

On May 5, 12:28 am, narutocan@yahoo.ca wrote:

...

read more »

hi

There was a bug in the code. I'm reposting because Google seems to
"hide" the changes.

(define (inter-reduce pred RG CRG)
  (define newCRG (delete '() CRG))
  (define newG '())
  (for-each (lambda (x y) (if (null? y) (set! newG (cons (NormalForm
pred x newCRG) newG))))
   RG CRG)
  (set! newG (delete '() (append newG newCRG)))
  newG
)
(define (completely-reduce-grobner pred RG)
 (if (< (length RG) 2) RG
  (let* ((CRG (completely-reduced? pred RG))
         (newG (inter-reduce pred RG CRG))
        )
        (if (not (null? (delete '() (check-grobner pred newG))))
(error "why?")
            (let ((newRG (reduce-grobner pred newG)))
                 (if (not (equal? newRG RG)) (completely-reduce-
grobner pred newRG)
                     (delete-duplicates newRG PcmpP)
                 )
            )
        )
  )
 )
)

Add to del.icio.us | Digg this | Stumble it | Powered by Megasolutions Inc