set.scm 16 KB
Newer Older
1 2
(define-module (ice-9 set set)
  #:use-module (ice-9 match)
3
  #:use-module (ice-9 format)
4 5
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
6
  #:export (<set> set? set-hash set-n
7
		  make-set-from-assoc make-set-from-assoc-mac set-size))
8 9 10 11

#|
This takes an assoc like library and transforms it to an ordered/undordered
set and setmap. There is a small change to the setup from scheme's assoc e.g.
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
the key value pair is not explicit in stead we assume the form (acons kv a). 

So consider every set constructed from a union if singletons, if an element is 
ordered, then they are guarrantead to be reproduced as they appear in the 
ordered list of union operations with a first come first defined principle. 
in a difference the oredered list remains but with the removed elements 
sieved out. This is as well for intersection. elements kan be key value pairs 
or just a key part, generally there is a poperty of beeing a value, a key 
value pair may be considered as having the value property but may be 
configured to not be a value. a value will be used in an assoc manner the value
 used is the first value that appears in the sequence of operations: 
unification or intersection, one can for example take an ordered set of non 
key-values and intersect on a key value set, then the resulting set/map will 
have the same order of the elements as in the non-value set, but have the 
values in the key-value set. We construct both a order perserving operations 
and non order preserving sets in order to be able to make a more effective set 
operation.
29 30 31 32 33 34

It is a higher order library, it takes a set of functions and construct set opaerations ,,,, ordered and unordered.

Input:
(make-set-from-assoc-mac ...) the macro version of the below
(make-set-from-assoc 
35
 null assoc acons delete hash mk-kv size value? order? equal?)
36

37
null    =  the empty assoc/set
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
assoc   =  (assoc x set/map),  maps to either a key value pair or x itself if 
                               x is a member of set, else #f
acons   =  (acons x set/map),  funcitonally add x to set/map
delete  =  (delete x set/map), functionally delete x from set/map
size    =  (size set/map)    , >= the number of elements, if deleted elements
                               conses a delete operation to the assoc then this
                               is greater then the number of elements in the set
element operations

mk-kv   = (mk-kv x), makes an element from a normal scheme value  
hash    = (hash x hashsize), creates a hash value from the element
value?  = if this is a key-value pair and the order of the kv pairs in set 
          operations are important
order?  = if the element's construction order is reflected by the set and 
          maintaind through the ordering of the set
equal?  = (equal? x y) the equality predicate used for the elements.

Output: set operations and iteratables

57 58 59 60 61

(values #:=     #:u   u  #:n   n  #:-  s- #:+  s+ #:<    #:<=   
	#:o=  o #:ou  ou #:on  on #:o- o- #:o+ o+ #:o< o #:o<= o
	#:fold fold #:map map #:for-each for-each #:empty 
	#:set->list set->list)
62 63 64 65

|#

(define-record-type <set>
66
  (make-set list assoc n hash meta)
67
  set?
68
  (list  set-list)
69 70
  (assoc set-assoc)
  (n     set-n)
71 72 73
  (hash  set-hash)
  (meta  set-meta))
	 
74

75 76
(define set-size set-n)

77 78
(set-record-type-printer! <set>
  (lambda (vl port) 
79 80 81 82
    (define (m x)
      (if (pair? x)
          (list (car x) (cdr x))
          (list x '())))
83
    (let ((n (set-n vl)))
84
      (if (= n 0)
85
	  (format port "∅")
86 87 88 89 90 91 92 93 94 95 96 97
	  (apply format port "{~a~{,~a~}}" (m ((car (set-meta vl)) vl)))))))

(set-object-property! <set> 'prolog-printer
  (lambda (lp vl avanced) 
    (define (m lp x) 
      (list (lp (car x)) (map lp (cdr x))))
    (let ((n (set-n vl)))
      (if (= n 0)
	  (format #f "∅")          
	  (apply format #f "{~a~{,~a~}}" (m lp ((car (set-meta vl)) vl)))))))


98 99

(define-record-type <append>
100
  (make-append- x y)
101 102 103 104
  append?
  (x append-x)
  (y append-y))

105 106 107 108 109 110
(define-record-type <append-rev>
  (make-append-rev- x y)
  append-rev?
  (x append-rev-x)
  (y append-rev-y))

111
(define (make-append x y)
112 113 114 115 116 117 118 119 120 121 122 123
  (cond
   ((null? x) y)
   ((null? y) x)
   (else
    (make-append- x y))))

(define (make-append-rev x y)
  (cond
   ((null? x) y)
   ((null? y) x)
   (else
    (make-append-rev- x y))))
124 125 126 127 128 129

(define-syntax-rule (define-tool 
		      make-setfkns 
		      make-setfkns-mac
		      (args ...) code ...)
  (begin
130
    (define             (make-setfkns     args ...) code ...)
131
    (define-syntax-rule (make-setfkns-mac args ...) (begin code ...))))
132 133

(define-tool make-set-from-assoc make-set-from-assoc-mac
134
  (null assoc acons delete hash mk-kv kv? kv-key kv-val sizefkn 
135
	value? order? equal? ar->l l->ar)
136 137


138
  (define  (make-set '() null 0 0 (list set->kvlist)))  
139 140 141

  (define size 10000000000000)

142
  (define (l-serie app)
143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
    (define mt null)
    (let lp ((app app))
      (match app
	 (($ <append-rev> x y)
	  (let ((yy (lp (ar->l y)))
		(xx (lp (ar->l x))))
	    (append xx yy)))
         (($ <append> x y)
	  (let ((xx (lp (ar->l x)))
		(yy (lp (ar->l y))))
	    (append xx  yy)))
	 ((x . l)
	  (if (assoc x mt)
	      (lp l)
	      (begin
		(set! mt (acons x mt))
		(cons x (lp l)))))
	 (x x))))
161

162 163 164 165
  (define (make-one x)
    (if (set? x)
	x
	(let ((kv (mk-kv x)))
166
	  (make-set (l->ar (list kv)) (acons kv null) 1 (hash kv size) 
167
		    (list set->kvlist)))))
168 169 170 171

  (define (set->* repr s)
    (match (make-one s)
      (($ <set> ll mm n h) 
172
       (let lp ((l '()) (ll (l-serie ll)))
173 174 175 176
	 (if (pair? ll)
	     (let ((kv (car ll)))
	       (if kv
		   (let ((kv (assoc kv mm)))
177 178
		     (if kv
			 (lp (cons (repr kv) l)      ;; li
179
			     (cdr ll))               ;; itarator
180 181
			 (lp l (cdr ll))))
		   (lp l (cdr ll))))
182
	     (reverse l))))))
183

184 185 186 187 188 189 190
  (define (reprl x)  (value? x) x (kv-key x))
  (define (repra x)  (cons (kv-key x) (kv-val x)))
  (define (reprid x) x)

  (define set->list    (lambda (x) (set->* reprl x)))
  (define set->assoc   (lambda (x) (set->* repra x)))
  (define set->kvlist  (lambda (x) (set->* reprid x)))
191 192

 
193 194 195
  ;; Takes a sequence ll associated to assoc mm at length nn and 
  ;; produce a new Set which has all slack removed
  (define (do-truncate ll mm nn)
196
    (when (> (sizefkn mm) nn)
197 198 199 200 201 202 203 204 205 206 207 208 209
      (let lp ((m null) (i 0) (l '()) (ll (l-serie ll)) (h 0))
	(if (pair? ll)
	    (let ((kv (car ll)))
	      (if kv		  
		  (let ((kv (assoc kv mm)))
		    (if (and kv (not (assoc kv m)))
			(lp (acons kv m)            ;; hash
			    (+ i 1)                 ;; len
			    (cons kv l)             ;; li
			    (cdr ll)                ;; itarator
			    (logxor h (hash kv size))) ;; h
			(lp m i l (cdr ll) h)))
		  (lp m i l (cdr ll) h)))
210
	    (make-set (l->ar (reverse l)) m i h (list set->kvlist))))))
211 212
  

213

214
  (define (maybe-truncate l m n h)
215
    (let ((nn (sizefkn m)))
216 217
      (if (> nn (* 2 n))
	  (do-truncate l m n)
218
	  (make-set    l m n h (list set->kvlist)))))
219 220 221

  (define ( x y)
    (match (list (make-one x) (make-one y))
222 223 224
      ((($ <set> lx mx nx hx) ($ <set> ly my ny hy))
       (if (= hx hy)
	   (if (= nx ny)
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239
	       (let lp ((lx (l-serie lx)))
		 (if (pair? lx)
		     (let ((kv (car lx)))
		       (if kv
			   (let ((kvx (assoc kv mx)))
			     (if kvx
				 (let ((kvy (assoc kv my)))
				   (if kvy
				       (if (equal? kvx kvy)
					   (lp (cdr lx))
					   #f)
				       #f))
				 (lp (cdr lx))))
			   (lp (cdr lx))))
		     #t))
240 241 242
	       #f)
	   #f))))

243
  (define (o x y)
244 245
    (match (list (make-one x) (make-one y))
      ((($ <set> lx mx nx hx) ($ <set> ly my ny hy))
246
       (let ()
247
       (define (do-the-iteration)
248
	 (let lp ((lx (l-serie lx)) (ly (l-serie ly)))
249 250 251
	   (if (pair? lx)
	       (let ((kvx (car lx)))
		 (if kvx
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298
		     (begin
		      (let ((kvxx (assoc kvx mx)))
			(if kvxx
			    (if (order? kvxx)
				(set! kvx kvxx)
				(let ((kvy (assoc kvxx my)))
				  (if kvy
				      (if (order? kvy)
					  (set! kvx kvxx)
					  (lp (cdr lx) ly))
				      #f)))
			    (lp (cdr lx) ly)))

		      (let lp2 ((ly ly))
			(if (pair? ly)
			    (let ((kvy (car ly)))
			      (begin
				(let ((kvyy (assoc kvy my)))
				  (if kvyy
				      (if (order? kvyy)
					  (set! kvy kvyy)
					  (let ((kvxx 
						 (assoc kvyy mx)))
					    (if kvxx
						(if (equal? kvxx 
							    kvx)
						    (lp (cdr lx) (cdr ly))
						    (if (order? kvxx)
							#f
							(lp2 (cdr ly))))
					
						#f)))
				      (lp2 (cdr ly))))
			     
				(if (equal? kvx kvy)
				    (lp (cdr lx) (cdr ly))
				    #f)))
			    #f)))
		     (lp (cdr lx) ly)))
	       (let lp2 ((ly ly))
		 (if (pair? ly)
		     (let ((ky (assoc (car ly) my)))
		       (if ky
			   #f
			   (lp2 (cdr ly))))
		     #t)))))
       
299 300
       (if (= hx hy)
	   (if (= nx ny)
301 302
	       (do-the-iteration)
	       #f)
303
	   #f)))))
304

305

306 307
  (define (next-mute lp ll l m n h)
    (lp (cdr ll) l m n h))
308

309 310
  (define (next-skip lp ll l m n h kv)
    (lp (cdr ll) l m n h))
311

312 313
  (define (next-cons-kv-on-list lp ll l m n h kv kv*)
    (lp (cdr ll) (cons kv l) m n h))
314
  
315 316
  (define (next-add-kv lp ll l m n h kv kv*)
    (lp (cdr ll) (cons kv* l) (acons kv* m)
317 318
	(+ n 1) (logxor h (hash kv* size))))

319 320
  (define (next-add-l  lp ll l m n h kv*)
    (lp (cdr ll) (cons kv* l) m n h))
321

322 323
  (define (next-swap-value lp ll l m n h kv kv* kv**)
    (lp (cdr ll) l (acons kv* m) n
324 325 326 327
	(logxor h 
		(logxor (hash kv*  size)
			(hash kv** size)))))

328
  (define (next-delete lp ll l m n h kv kv*)
329 330 331 332 333 334 335 336 337 338
    (lp (cdr ll) l
	(delete kv* m) 
	(- n 1)
	(logxor h (hash kv* size))))

  ;;TODO MAKE USE OF APPEND CONSTRUCT MAKE USE OF VLISTS? MAYBE?
  (define-syntax-rule (mku ou is-ordered-set?)
  (define ou 
    (case-lambda
     (()   )
339
     ((x)  (make-one x))
340
     ((x y)
341 342 343 344 345 346 347 348
      (let* ((x     (make-one x))
	     (y     (make-one y))
	     (nx    (set-n x))
	     (ny    (set-n y))
	     (mx    (set-assoc x))
	     (my    (set-assoc y))
	     (lx    (set-list  x))
	     (ly    (set-list  y)))
349 350 351 352 353 354 355
	(cond
	 ((= nx 0)
	  (if (= ny 0)
	      
	      y))
	 ((= ny 0)
	  x)
356
	 ((or (< nx 10) (< nx ny))
357
	  (let lp ((ll (l-serie lx))
358
		   (l  '()) (m my) (n ny) (h (set-hash y)))
359
	      
360
	    (define-syntax-rule (next f . lll)
361
	      (f lp ll l m n h . lll))
362 363 364

	    (if (pair? ll)
		(let ((kv (car ll)))
365 366 367 368 369 370 371 372 373 374 375 376 377 378
		  (let ((kvx (assoc kv mx)))
		    (if kvx
			(let ((kvy (assoc kv my)))
			  (if (value? kvx)
			      (if kvy
				  (next next-swap-value kv kvx kvy)
				  (next next-add-kv kv kvx))
			      (if kvy
				  (if (order? kvx)
				      (next next-cons-kv-on-list kv kvx)
				      (next next-skip kv))
				  (next next-add-kv kv kvx))))
			(next next-mute))))
		(maybe-truncate (make-append (l->ar (reverse l)) ly)
379 380 381
				m n h))))
	  
	 (else
382
	  (let lp ((ll      (l-serie ly))
383
		   (l  '()) (m mx) (n nx) (h (set-hash x)))
384
	      
385
	    (define-syntax-rule (next f . lll)
386
	      (f lp ll l m n h . lll))
387
	      
388 389
	    (if (pair? ll)
		(let ((kv (car ll)))
390 391 392 393 394 395 396 397 398 399 400 401
		  (let ((kvx (assoc kv mx)))
		    (if kvx
			(let ((kvy (assoc kv my)))
			  (if kvy		  
			      (if (and (value? kvy) (not (value? kvx)))
				  (next next-swap-value kv kvy kvx)
				  (next next-skip kv))
			      (next next-mute)))
			(let ((kvy (assoc kv my)))
			  (if kvy
			      (next next-add-kv kv kvy)
			      (next next-mute))))))
402
		(maybe-truncate 
403
		 (make-append-rev lx (l->ar (reverse l))) m n h)))))))
404
     ((x y . l)
405
      (ou x (apply ou y l))))))
406 407 408 409 410 411 412 413 414

  (mku ou #t)
  (mku u  #f)

  (define-syntax-rule (mkn on is-ordered-set?)
  (define on 
    (case-lambda
     ((x)  x)
     ((x y)
415 416 417 418 419 420 421 422
      (let* ((x     (make-one x))
	     (y     (make-one y))
	     (nx    (set-n x))
	     (ny    (set-n y))
	     (mx    (set-assoc x))
	     (my    (set-assoc y))
	     (lx    (set-list  x))
	     (ly    (set-list  y)))
423

424 425 426
	(cond
	 ((or (= nx 0) (= ny 0))
	  )
427

428 429
	 ((or (< nx 10) (< nx (* 2 ny)))
	  (let lp ((ll (l-serie lx)) (l '())
430
		   (m mx) (n nx) (h (set-hash x)))
431

432
	      (define-syntax-rule (next f . lll) (f lp ll l m n h . lll))
433 434
	      (if (pair? ll)
		  (let ((kv (car ll)))
435 436 437 438 439 440 441 442 443 444
		    (let ((kvx (assoc kv mx)))
		      (if kvx
			  (let ((kvy (assoc kv my)))
			    (if kvy
				(if (and (value? kvy) 
					 (not (value? kvx)))
				    (next next-swap-value kv kvy kvx)
				    (next next-skip kv))
				(next next-delete kv kvx)))
			  (next next-skip kv))))
445 446
		  (maybe-truncate lx m n h))))
	 (else
447
	    (let lp ((ll (l-serie ly))
448
		     (l  ly)
449
		     (m my) (n ny) (h (set-hash y)))
450
	      
451
	      (define-syntax-rule (next f . lll) (f lp ll l m n h . lll))
452 453
	      (if (pair? ll)
		  (let ((kv (car ll)))
454 455 456 457 458 459 460
		    (let ((kvy (assoc kv my)))
		      (if kvy
			  (let ((kvx (assoc kv mx)))
			    (if kvx
				(if (value? kvx)
				    (if (order? kvx)
					(next next-swap-value kv kvx kvy)
461
					(next next-skip kv))
462 463 464
				    (next next-skip kv))
				(next next-delete kv kvy)))
			  (next next-mute))))
465 466
		  (if (is-ordered-set?)
		      (maybe-truncate lx m n h)		   
467
		      (maybe-truncate ly m n h))))))))
468 469 470 471

     ((x y . l)
      (on x (apply on y l))))))

472 473
  (mkn on #t)
  (mkn n  #f)
474

475 476 477 478 479 480 481 482 483 484 485 486 487 488 489
  (define tripple 
    (lambda (x y z)
      (let* ((x     (make-one x))
	     (y     (make-one y))
	     (z     (make-one z))
	     (nx    (set-n x))
	     (ny    (set-n y))
	     (nz    (set-n z))
	     (mx    (set-assoc x))
	     (my    (set-assoc y))
	     (mz    (set-assoc z))
	     (lx    (set-list  x))
	     (ly    (set-list  y)))

	(cond
490
	 ((= nx 0)
491
	  )
492 493 494 495 496
	 ((= nz 0)
	  (if (= ny 0)
	        
	      (on x y)))
	 ((= ny 0)
497
	  (o- x z))
498 499
	 (else
	  (let lp ((ll (l-serie lx)) (l '())
500
		   (m mx) (n nx) (h (set-hash x)))
501

502
	    (define-syntax-rule (next f . lll) (f lp ll l m n h . lll))
503 504
	    (if (pair? ll)
		(let ((kv (car ll)))
505 506 507 508 509 510 511 512 513 514 515 516
		  (let ((kvx (assoc kv mx)))
		    (if kvx
			(let ((kvy (assoc kv my)))
			  (if kvy
			      (if (and (value? kvy) 
				       (not (value? kvx)))
				  (next next-swap-value kv kvy kvx)
				  (next next-skip kv))
			      (if (not (assoc kv mz))
				  (next next-skip kv)
				  (next next-delete kv kvx))))
			(next next-skip kv))))
517 518
		(maybe-truncate lx m n h))))))))

519
 (define-syntax-rule (mk- o- is-ordered-set?)
520 521 522 523
  (define o- 
    (case-lambda
     ((x)  x)
     ((x y)
524 525 526 527 528 529 530 531
      (let* ((x     (make-one  x))
	     (y     (make-one  y))
	     (nx    (set-n     x))
	     (ny    (set-n     y))
	     (mx    (set-assoc x))
	     (my    (set-assoc y))
	     (lx    (set-list  x))
	     (ly    (set-list  y)))
532

533 534 535 536 537 538 539
	(cond
	 ((= nx 0)
	  )
	 ((= ny 0)
	  x)
	 (else
	  (let lp ((ll (l-serie lx)) (l '())
540
		   (m mx) (n nx) (h (set-hash x)))
541
	      
542 543
	    (define-syntax-rule (next f . lll) (f lp ll l m n h . lll))
	    
544 545
	    (if (pair? ll)
		(let ((kv (car ll)))
546 547 548 549 550 551
		  (let ((kvx (assoc kv mx)))
		    (if kvx
			(if (assoc kv my)
			    (next next-delete kv kvx)
			    (next next-skip kv))			  
			(next next-mute))))
552
		(maybe-truncate lx m n h)))))))
553 554 555 556
		
     ((x y . l)
      (apply o- (o- x y) l)))))

557 558
  (mk- o- #t)
  (mk- s- #f)
559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578

  (define o+ 
    (case-lambda
     (()  )
     ((x) x)
     ((x y)
      (ou (o- x y) (o- y x)))
     ((x y . l)
      (o+ x (apply o+ y l)))))

  (define s+ 
    (case-lambda
     (()  )
     ((x) x)
     ((x y)
      (u (s- x y) (s- y x)))
     ((x y . l)
      (s+ x (apply s+ y l)))))

  (define (fold f seed set)
579
    (let lp ((l  (l-serie (set-list set)))
580
	     (m  (set-assoc set)))	     
581
      (let lp ((l l) (seed seed))
582 583
	(if (pair? l)
	    (let ((kv (car l)))
584 585 586 587
	      (let ((kv (assoc kv m)))
		(if kv
		    (lp (cdr l) (f kv seed))
		    (lp (cdr l) seed))))
588 589
	    seed))))

590 591 592 593 594 595 596
  (define (in x s)
    (match (make-one s)
     (($ <set> l m n h)
      (assoc (mk-kv x) m))))

  (define ( x y)
    ( (n x y) x))
597 598


599
  (define (o x y)
600
    (o (on y x) x))
601 602 603 604 605 606 607

  (define ( x y)
    (and (not ( x y)) ( x y)))

  (define (o x y)
    (and (not ( x y)) ( x y)))

608 609 610 611
  (define (map f set) 
    (reverse (fold (lambda (k seed) (cons (f k) seed)) '() set)))
  (define (for-each f set) 
    (reverse (fold (lambda (k seed) (f k) seed) (if #f #f) set)))
612

613 614 615 616 617 618 619 620 621 622
  (define (member x s)
    (let ((r (assoc (mk-kv x) (set-assoc s))))
      (if r
          (if (kv? r)
              (cons (kv-key r) (kv-val r))
              r)
          r)))

  (values #:member member
          #:=     #:u   u  #:n   n  #:-  s- #:+  s+ #:<    #:<=   
623
	  #:o=  o #:ou  ou #:on  on #:o- o- #:o+ o+ #:o< o #:o<= o
624 625
 	  #:n- tripple
	  #:in in #:fold fold #:map map #:for-each for-each #:empty 
626
	  #:set->list set->list #:set->assoc set->assoc 
627
	  #:set->kvlist set->kvlist #:make-one make-one))
628 629