hash.scm 5.07 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 14
  #:export (make_vhash vhash vhashp vhash_ref vhashq_ref vhashql_ref 
		       vhash_cons vhashq_cons vhashql_cons
15
                       peek_vhash vhash_to_assoc))
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 43

(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.

|#

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

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

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

64 65 66 67 68 69 70 71 72 73 74 75 76
(<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))))))))

77 78 79 80 81 82 83 84 85 86 87 88 89
(<define> (vhashql_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-assoc k (fluid-ref h))))
	(when val
	  (<=> ,val (_ . ret))))))))

90 91 92 93 94 95 96 97 98
(<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))
99
      (type_error vhash h))
100 101 102
     (else
      (<code> (fluid-set! h (vhash-cons k v (fluid-ref h))))))))

103

104 105 106 107 108 109 110 111 112
(<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
113
      (<code> (fluid-set! h (vhash-consq k
114 115
                                         (<lookup> v) (fluid-ref h))))))))

116 117 118 119 120 121 122 123 124 125 126 127
(<define> (vhashql_cons h k v)
  (<let*> ((h    (<lookup> h))
	   (k    (<lookup> k)))
    (cond
     ((<var?> h)
      (instantiation_error))
     ((not (<vhash?> h))
      (type_error vhash h))
     (else
      (<code> (fluid-set! h (vhash-cons k
					(<lookup> v) (fluid-ref h))))))))

128
(<define> (peek_vhash h)
129 130 131
 (<code> (analyze (fluid-ref (<lookup> h)))))

(define (analyze x)
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
  (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)))) 
152
                    
153 154 155 156 157
                  (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>~%")))
158 159 160 161 162 163 164 165 166

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