first version of inheritance is now tested

parent b9856469
(define-module (logic guile-log inheritance)
#:use-module (logic guile-log dynlist)
#:use-module (ice-9 pretty-print)
#:export
(
bits-to-is get-high-bit get-rest-bits
make-set-theory
new-set a->b
print-theory
))
;; Syntax helpers
......@@ -71,6 +73,9 @@ This is prepared to make it functional, but currently we mutate
(define-inlinable (put-i->sups x k v)
(hash-set! (get-i->sups x) k v))
(define-inlinable (get-i ->i i) (hash-ref ->i i #f))
(define-inlinable (update ->i i v) (begin (hash-set! ->i i v) ->i))
(define-syntax-rule (update-set-theory th . l)
(let ((ll (list . l)))
(aif (r) (member #:set ll)
......@@ -91,6 +96,27 @@ This is prepared to make it functional, but currently we mutate
#|
Basic construction and removal of set and set graph relationship,
|#
(define print-theory
(case-lambda
(() (print-theory (fluid-ref *current-set-theory*)))
((theory)
(define out '())
(hash-for-each
(lambda (i s)
(define target '())
(set! out
(cons
(list s
(let lp ((l (bits-to-is (get-i (get-i->subs theory) i))))
(if (pair? l)
(cons
(get-i (get-i->set theory) (car l))
(lp (cdr l)))
'())))
out)))
(get-i->set theory))
(pretty-print out))))
(define new-set
(case-lambda
((set)
......@@ -107,8 +133,6 @@ Basic construction and removal of set and set graph relationship,
#:sups (put-i->sups theory j j))))))
(define-inlinable (get-i ->i i) (hash-ref ->i i #f))
(define-inlinable (update ->i i v) (hash-set! ->i i v))
(define a->b
(case-lambda*
((set-a set-b)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment