set-theory.scm 1.06 KB
Newer Older
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
1 2 3 4 5 6 7 8 9
(define-module (logic guile-log guile-prolog set-theory)
  #:use-module (logic guile-log)
  #:use-module (logic guile-log vset)
  #:use-module (logic guile-log iso-prolog)
  #:use-module (logic guile-log guile-prolog set)
  #:use-module (logic guile-log inheritance)
  #:export (use_set_theory sets_to_theory))


Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
10 11 12 13 14 15
(define (sets->theory sets s)
  (let lp ((l sets))
    (if (pair? l)
	(begin
	  (new-set (car l))
	  (lp (cdr l)))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
16
    
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
  (let lp1 ((l1 sets))
    (if (pair? l1)
	(begin
	  (let lp2 ((l2 (cdr l1)))
	    (if (pair? l2)
		(begin
		  (begin
		    (cond
		     ((<wrap-s> subset-scm s (car l1) (car l2))
		      (a->b (car l2) (car l1)))
		     ((<wrap-s> subset-scm s (car l2) (car l1))
		      (a->b (car l1) (car l2)))
		     (else #t))
		    (lp2 (cdr l2))))
		(lp1 (cdr l1))))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
32 33 34 35

(<define> (use_set_theory theory)
  (<code> (fluid-set! *current-set-theory* (<lookup> theory))))

Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
36
(<define> (sets_to_theory sets)
37 38 39 40
  (let lp ((l sets) (ll '()))
    (<match> (#:mode -) (l)
      ((x . l) (lp l (cons (<lookup> x) ll)))
      (()
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
41
       (<code> (sets->theory ll S))))))
Stefan Israelsson Tampe's avatar
Stefan Israelsson Tampe committed
42