hash.scm 4.46 KB
Newer Older
1 2 3 4 5 6
(define-module (logic guile-log guile-prolog hash)
  #:use-module (logic guile-log iso-prolog)
  #:use-module (logic guile-log canonacalize)
  #:use-module (logic guile-log hash)
  #:use-module (logic guile-log vlist)
  #:use-module (logic guile-log umatch)
7
  #:use-module (logic guile-log prolog names)
8 9
  #:use-module (logic guile-log prolog util)
  #:use-module (logic guile-log prolog error)
10
  #:use-module (logic guile-log dynamic-features)
11 12
  #:use-module (logic guile-log prolog goal-transformers)
  #:use-module (logic guile-log)
13
  #:export (make_vhash vhash vhashp vhash_ref vhashq_ref vhash_cons vhashq_cons
14
                       peek_vhash vhash_to_assoc))
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42

(mk-sym vhash)

;;  TODO: debug and stabilize the C-vlist code
;;  TODO: These hashes get's bloated if we do a lot of hash-cons in which case

;;  onw might wand hash_set_x!! in stead of vhash-cons
;;  We need to support vectors or f(X) like objects

;;  TODO: vhash must be intelligent with respect to truncate
;;  TODO: EQ, hashes EQV hashes?
;;  TODO: hash fold
;;  TODO: region guarding.

#|

vhashes works like an association list where seting new values is done by
consing a new pair to the top of the list and therefore shading the old pair
it is possible to set it and remove th eold value but that is an expensive
operation, it is not uncommon to have this restriction. Another nice feature 
we have with the vhash is that it can backtrack very effectively and is a well
optimized datastructure for doing this. But it is backtracking with 
intelligence! If a value is stored in e.g. an interleaving operation it will
handle that and make act to chain a frech new datastructure else it will reuse
it's old datastructure.

|#

43 44 45 46 47 48 49
(<define> (make_vhash H)
  (<let> ((h (<make-vhash>)))
    (add-vhash-dynamics h)
    (<=> H h)))

(<define> (vhashp x) (when (<vhash?> (<lookup> x))))

50 51 52 53 54 55 56
(<define> (vhash_ref h k ret)
  (<let> ((h   (<lookup> h))
	  (k   (canon-it k S)))
    (cond
     ((<var?> h)
      (instantiation_error))
     ((not (<vhash?> h))
57
      (type_error vhash h))
58 59 60 61 62
     (else
      (<let> ((val (vhash-assoc (<scm> k) (fluid-ref h))))
	(when val
	  (<=> ,(un-canon-it val) (k . ret))))))))

63 64 65 66 67 68 69 70 71 72 73 74 75
(<define> (vhashq_ref h k ret)
  (<let> ((h   (<lookup> h))
	  (k   (<lookup> k)))
    (cond
     ((<var?> h)
      (instantiation_error))
     ((not (<vhash?> h))
      (type_error vhash h))
     (else
      (<let> ((val (vhash-assq k (fluid-ref h))))
	(when val
	  (<=> ,val (_ . ret))))))))

76 77 78 79 80 81 82 83 84
(<define> (vhash_cons h k v)
  (<let*> ((h    (<lookup> h))
	   (k.v  (canon-it (cons k v) S))
	   (k    (car k.v))
	   (v    (cdr k.v)))
    (cond
     ((<var?> h)
      (instantiation_error))
     ((not (<vhash?> h))
85
      (type_error vhash h))
86 87 88
     (else
      (<code> (fluid-set! h (vhash-cons k v (fluid-ref h))))))))

89 90 91 92 93 94 95 96 97
(<define> (vhashq_cons h k v)
  (<let*> ((h    (<lookup> h))
	   (k    (<lookup> k)))
    (cond
     ((<var?> h)
      (instantiation_error))
     ((not (<vhash?> h))
      (type_error vhash h))
     (else
98
      (<code> (fluid-set! h (vhash-consq k
99 100
                                         (<lookup> v) (fluid-ref h))))))))

101
(<define> (peek_vhash h)
102 103 104
 (<code> (analyze (fluid-ref (<lookup> h)))))

(define (analyze x)
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124
  (if (vlist? x)
      (let ((a (struct-ref x 0))
            (b (struct-ref x 1)))
        (format #t "<vhash> offset = ~a, " b)
        (let ((block (vector-ref a 0))
              (off   (vector-ref a 2))
              (size  (vector-ref a 3))
              (free  (vector-ref a 4)))
          (format #t " size ~a, free ~a~%" size free)
          (let lp ((i b))
            (if (>= i 0)
                (let* ((next (number->string
                              (logand #xffffffff 
                                      (vector-ref block (+ (* size 3) i)))
                              16))
                       (back (ash
                              (vector-ref block (+ (* size 3) i))
                              -32))
                       (hash (vector-ref block (+ (* size 2) back)))
                       (v    (object-address (vector-ref block i)))) 
125
                    
126 127 128 129 130
                  (format #t "~a: next ~a, back ~a hashv ~a key ~a~%" 
                          i next back 
                          hash (number->string v 16))
                  (lp (- i 1)))))))
      (format #t "<assoc>~%")))
131 132 133 134 135 136 137 138 139 140

(<define> (vhash_to_assoc h l)
   (<let> ((h (<lookup> h)))
    (cond
     ((<var?> h)
      (instantiation_error))
     ((not (<vhash?> h))
      (type_error vhash h))
     (else 
       (<=> l (vhash->assoc (fluid-ref h)))))))