;;
;;  Cis : compact integer sets
;;
;;  This module implements compact integer sets, represented as a list
;;  of integer intervals. The usual set operations are provided.  The
;;  advantage compared to ordered lists is that the actual size may be
;;  smaller than the cardinal of a set when many elements are
;;  contiguous. Most set operations are linear w.r.t. the size, not
;;  the cardinal.
;;
;;  Based on the Ocaml Cis library by Sébastien Ferré <ferre@irisa.fr>.
;;  Ported to Chicken Scheme by Ivan Raikov.
;;  
;;  Copyright 2010-2011 Ivan Raikov and the Okinawa Institute of Science and Technology.
;;
;;  This program is free software: you can redistribute it and/or
;;  modify it under the terms of the GNU Lesser General Public License
;;  as published by the Free Software Foundation, either version 3 of
;;  the License, or (at your option) any later version.
;;
;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;  Lesser General Public License for more details.
;;
;;  A full copy of the Lesser GPL license can be found at
;;  <http://www.gnu.org/licenses/>.
;;


(module cis


	(cis? empty? empty 
	 subset? cardinal in?
	 singleton interval add shift remove 
	 get-min get-max union intersection difference 
	 foreach fold-left fold-right elements 
	 )

	(import scheme chicken)


;; Variant types 

(define-syntax define-datatype
  (syntax-rules ()
    [(_ type (name field ...) ...)
     (begin
       (define-constructors type ((name field ...) ...)))]))


(define-syntax define-constructors
  (syntax-rules ()
    [(define-constructors type ((name field ...) ...))
     (define-constructors type ((name field ...) ...) (name ...))]
    [(define-constructors type ((name field ...) ...) names)
     (begin
       (define-constructor type (name field ...) names)
       ...)]))


(define-syntax define-constructor
  (syntax-rules ()
    [(_ type (name field ...) names)
     (define (name field ...)
       (cons 'type
             (lambda names
               (name field ...))))]))


(define-syntax cases
  (syntax-rules ()
    [(_ type x [(name field ...) exp]
          ...)
     ((cdr x) (lambda (field ...) exp)
              ...)]))


(define (fold-for f a b e)
  (if (fx< b a) (fold-for f b a e)
      (let recur ((i a) (res e))
	(if (fx<= i b) (recur (fx+ 1 i) (f i res))
	    res))))

	
(define (fold-for-down f a b e)
  (if (fx< a b) (fold-for-down f b a e)
      (let recur ((i a) (res e))
	(if (fx>= i b) (recur (fx- i 1) (f i res))
	    res))))


;; integers in decreasing order 
(define-datatype cis
  (Nil)
  (Single i t)
  (Interv i j t))

(define (cis? x) (and (pair? x) (eq? 'cis (car x))))

  (define (empty? x)
    (cases cis x 
	   ((Nil) #t)
	   ((Single _ _) #f)
	   ((Interv _ _ _) #f)))
  

  (define empty (Nil))

  (define (subset? t1 t2)
    (cases cis t1
	   ((Nil)  #t)
	   ((Single x1 t1-tail) 
	    (cases cis t2
		   ((Nil)  #f)
		   ((Single x2 t2-tail)
		    (cond ((fx> x1 x2)  #f)
			  ((fx> x2 x1)  (subset? t1 t2-tail))
			  (else (subset? t1-tail t2-tail))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((fx> x1 xmax2)  #f)
			  ((fx> xmin2 x1)  (subset? t1 t2-tail))
			  (else (subset? t1-tail t2))))))
	   ((Interv xmax1 xmin1 t1-tail)
	    (cases cis t2
		   ((Nil)  #f)
		   ((Single x2 t2-tail)
		    (cond ((fx> x2 xmax1)  (subset? t1 t2-tail))
			  ((fx> xmin1 x2)  #f)
			  (else #f)))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((fx> xmin2 xmax1)  (subset? t1 t2-tail))
			  ((fx> xmin1 xmax2)  #f)
			  (else (and (fx>= xmax2 xmax1) (fx>= xmin1 xmin2) (subset? t1-tail t2)))))
		   ))
	   ))

  
  (define (get-max t)
    (cases cis t
	   ((Nil)  (error 'get-max "set is empty"))
	   ((Single x _)  x)
	   ((Interv xmax _ _)  xmax)))
  
  
  (define (get-min t)
    (cases cis t
	   ((Nil) (error 'get-min "set is empty"))
	   ((Single x t1) (if (empty? t1) x (get-min t1)))
	   ((Interv xmax xmin t1) (if (empty? t1) xmin (get-min t1)))))
  
  
  (define (cons-single x t)
    (cases cis t
	   ((Nil) 
	    (Single x (Nil)))
	   ((Single x1 t1) 
	    (if (fx= x (fx+ 1 x1)) (Interv x x1 t1) (Single x t)))
	   ((Interv xmax1 xmin1 t1) 
	    (if (fx= x (fx+ 1 xmax1)) (Interv x xmin1 t1) (Single x t)))
	   ))


  (define (cons-interval xmax xmin t)
    (cond ((fx< xmax xmin) (cons-interval xmin xmax t))
	  ((fx= xmax xmin) (cons-single xmin t))
	  (else
	 (cases cis t
		((Nil) 
		 (Interv xmax xmin (Nil)))
		((Single x1 t1) 
		 (if (fx= xmin (fx+ 1 x1)) (Interv xmax x1 t1) (Interv xmax xmin t)))
		((Interv xmax1 xmin1 t1) 
		 (if (fx= xmin (fx+ 1 xmax1)) (Interv xmax xmin1 t1) (Interv xmax xmin t)))
		))))
  
  
  (define (cardinal t)
    (let recur ((t t) (ax 0))
      (cases cis t
	     ((Nil) ax)
	     ((Single x1 t1) (recur t1 (fx+ 1 ax)))
	     ((Interv xmax1 xmin1 t1) (recur t1 (fx+ ax (fx+ 1 (fx- xmax1 xmin1)))))
	     )))
  

  (define (in? x t)
    (cases cis t
	   ((Nil) #f)
	   ((Single x1 t1) 
	    (or (fx= x x1) (and (fx> x1 x) (in? x t1))))
	   ((Interv xmax xmin t1) 
	    (or (and (fx>= xmax x) (fx>= x xmin))
		(and (fx> xmin x) (in? x t1))))
	   ))


(define (singleton x)
  (Single x (Nil)))


(define (interval xmin xmax)
  (cond ((fx> xmin xmax) (interval xmax xmin))
	((fx= xmin xmax) (singleton xmin))
	(else
	 (Interv xmax xmin (Nil)))))


(define (add x t)
  (cases cis t
	 ((Nil) (cons-single x t))
	 ((Single x1 t1) (cond ((fx> x x1) (cons-single x t))
			       ((fx= x x1) t)
			       (else (cons-single x1 (add x t1)))))
	 ((Interv xmax1 xmin1 t1) (cond ((fx> x xmax1) (cons-single x t))
					((and (fx>= xmax1 x) (fx>= x xmin1)) t)
					(else (cons-interval xmax1 xmin1 (add x t1)))))
	   
	 ))

(define (remove x t)
  (cases cis t
	 ((Nil) empty)
	 ((Single x1 t1) 
	  (cond ((fx> x x1) t)
		((fx= x x1) t1)
		(else (cons-single x1 (remove x t1)))))
	 ((Interv xmax1 xmin1 t1) 
	  (cond ((fx> x xmax1) t)
		((fx= x xmin1)
		 (cons-interval xmax1 (fx+ 1 xmin1) t1))
		((fx= x xmax1)
		 (cons-interval (fx- xmax1 1) xmin1 t1))
		((and (fx> xmax1 x) (fx> x xmin1)) 
		 (cons-interval xmax1 (fx+ 1 x) (cons-interval (fx- x 1) xmin1 t1)))
		(else (cons-interval xmax1 xmin1 (remove x t1)))))
	 
	 ))


(define (shift n t)
  (if (empty? t) t
      (let ((m (get-min t)))
	(and (fx<= 0 (fx+ m n))
	     (cases cis t
		    ((Nil) (Nil))
		    ((Single x1 t1)  (Single (fx+ x1 n) (shift n t1)))
		    ((Interv xmax1 xmin1 t1) 
		     (Interv (fx+ xmax1 n) (fx+ xmin1 n) (shift n t1)))
		    )))))
  
  

(define (union t1 t2)
  (cases cis t1
	 ((Nil) t2)
	 ((Single x1 t1-tail) 
	  (cases cis t2
		 ((Nil) t1)
		 ((Single x2 t2-tail) 
		  (cond ((fx> x1 (fx+ 1 x2))
			 (cons-single x1 (union t1-tail t2)))
			((fx> x2 (fx+ 1 x1))
			 (cons-single x2 (union t1 t1-tail)))
			((fx= x1 (fx+ 1 x2))
			 (cons-interval x1 x2 (union t1-tail t2-tail)))
			((fx= x2 (fx+ 1 x1))
			 (cons-interval x2 x1 (union t1-tail t2-tail)))
			(else
			 (cons-single x1 (union t1-tail t2-tail)))
			))
		 ((Interv xmax2 xmin2 t2-tail) 
		  (cond ((fx> x1 xmax2) (cons-single x1 (union t1-tail t2)))
			((fx> xmin2 (fx+ 1 x1)) (cons-interval xmax2 xmin2 (union t1 t2-tail)))
			((fx= xmin2 (fx+ 1 x1)) (cons-interval xmax2 x1 (union t1-tail t2-tail)))
			(else (cons-interval xmax2 x1 (union t1-tail (cons-interval (fx- x1 1) xmin2 t2-tail))))))
		 ))
	 ((Interv xmax1 xmin1 t1-tail) 
	  (cases cis t2
		 ((Nil) t1)
		 ((Single x2 t2-tail) 
		  (cond ((fx> x2 xmax1) (cons-single x2 (union t1 t2-tail)))
			((fx> xmin1 (fx+ 1 x2)) (cons-interval xmax1 xmin1 (union t1-tail t2)))
			((fx= xmin1 (fx+ 1 x2)) (cons-interval xmax1 x2 (union t1-tail t2-tail)))
			(else (cons-interval xmax1 x2 (union (cons-interval (fx- x2 1) xmin1 t1-tail) t2-tail)))))
		 ((Interv xmax2 xmin2 t2-tail) 
		  (cond ((fx> xmin2 xmax1) (cons-interval xmax2 xmin2 (union t1 t2-tail)))
			((fx> xmin1 xmax2) (cons-interval xmax1 xmin1 (union t1-tail t2)))
			(else (cons-interval (fxmax xmax1 xmax2) (fxmax xmin1 xmin2)
					     (cond ((fx= xmin1 xmin2) 
						    (union t1-tail t2-tail))
						   ((fx> xmin1 xmin2) 
						    (union t1-tail (cons-interval (fx- xmin1 1) xmin2 t2-tail)))
						   (else 
						    (union (cons-interval (fx- xmin2 1) xmin1 t1-tail) t2-tail)))))
			))
		 ))
	 ))


(define (intersection t1 t2)
  (cases cis t1
	 ((Nil) empty)
	   ((Single x1 t1-tail) 
	    (cases cis t2
		   ((Nil) empty)
		   ((Single x2 t2-tail) 
		    (cond ((fx> x1 (fx+ 1 x2))
			   (intersection t1-tail t2))
			  ((fx> x2 (fx+ 1 x1))
			   (intersection t1 t2-tail))
			  ((fx= x1 (fx+ 1 x2))
			   (intersection t1-tail t2-tail))
			  ((fx= x2 (fx+ 1 x1))
			   (intersection t1-tail t2-tail))
			  (else
			   (cons-single x1 (intersection t1-tail t2-tail)))
			  ))
		   ((Interv xmax2 xmin2 t2-tail) 
		    (cond ((fx> x1 xmax2) (intersection t1-tail t2))
			  ((fx> xmin2 x1) (intersection t1 t2-tail))
			  (else (cons-single x1 (intersection t1-tail t2)))))
		   ))
	   ((Interv xmax1 xmin1 t1-tail) 
	    (cases cis t2
		   ((Nil)  empty)
		   ((Single x2 t2-tail)
		    (cond ((fx> x2 xmax1)  (intersection t1 t2-tail))
			  ((fx> xmin1 x2)  (intersection t1-tail t2))
			  (else (cons-single x2 (intersection t1 t2-tail)))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((fx> xmin2 xmax1) (intersection t1 t2-tail))
			  ((fx> xmin1 xmax2) (intersection t1-tail t2))
			  (else (cons-interval (min xmax1 xmax2) (max xmin1 xmin2)
					       (if (fx>= xmin1 xmin2) 
						   (intersection t1-tail t2)
						   (intersection t1 t2-tail))))))
		   ))
	   ))
  
  (define (difference t1 t2)
    (cases cis t1
	   ((Nil) empty)
	   ((Single x1 t1-tail) 
	    (cases cis t2
		   ((Nil)  t1)
		   ((Single x2 t2-tail)
		    (cond ((fx> x1 x2)  (cons-single x1 (difference t1-tail t2)))
			  ((fx> x2 x1)  (difference t1 t2-tail))
			  (else (difference t1-tail t2-tail))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((fx> x1 xmax2) (cons-single x1 (difference t1-tail t2)))
			  ((fx> xmin2 x1) (difference t1 t2-tail))
			  (else (difference t1-tail t2-tail))))))
	   ((Interv xmax1 xmin1 t1-tail)
	    (cases cis t2
		   ((Nil)  t1)
		   ((Single x2 t2-tail)
		    (cond ((fx> x2 xmax1)  (difference t1 t2-tail))
			  ((fx> xmin1 x2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
			  (else  (cons-interval xmax1 (fx+ 1 x2) (difference (cons-interval (fx- x2 1) xmin1 t1-tail) 
									     t2-tail)))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((fx> xmin2 xmax1)  (difference t1 t2-tail))
			  ((fx> xmin1 xmax2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
			  (else
			   (cons-interval xmax1 (fx+ 1 xmax2)
					  (if (fx>= xmin1 xmin2)
					      (difference t1-tail t2)
					      (difference (cons-interval (fx- xmin2 1) xmin1 t1-tail)
							  t2-tail))))))
		   ))
	   ))
  
  
  
(define (foreach f t)
  (let outer ((t t))
    (cases cis t
	   ((Nil)  (begin))
	   ((Single x t-tail)  (begin (f x) (outer t-tail)))
	   ((Interv xmax xmin t-tail) 
	    (begin
	      (let inner ((x xmax))
		(begin (f x)
		       (if (fx> x xmin) (inner (fx- x 1)))))
	      (outer t-tail)))
	   )))

(define (fold-left f init t)
  (cases cis t
	 ((Nil)  init)
	 ((Single x t-tail)
	  (fold-left f (f x init) t-tail))
	 ((Interv xmax xmin t-tail)
	  (fold-left f (fold-for-down (lambda (x res) (f x res)) xmax xmin init) t-tail))
	 ))

(define (fold-right f init t)
  (cases cis t
	 ((Nil)  init)
	 ((Single x t-tail)
	  (f x (fold-right f init t-tail)))
	 ((Interv xmax xmin t-tail)
	  (fold-for f xmin xmax (fold-right f init t-tail)))
	 ))

(define (elements t) (fold-right cons '() t))

#|
  
  (define (append t1 t2) ;; assumes (get-min t1) > (get-max t2) 
    (if (empty? t2) t1
	(let recur ((t1 t1) (m (get-max t2)) (t2 t2))
	  (cases cis t1
	       ((Nil)   t2)
	       ((Single x t1)
		(if (empty? t1) 
		    (if (fx= x (fx+ 1 m)) (cons-single x t2) (Single x t2))
		    (Single x (recur t1 m t2))))
	       ((Interv xmax xmin t1)
		(if (empty? t1)
		    (if (fx= xmin (fx+ 1 m)) (cons-interval xmax xmin t2) (Interv xmax xmin t2))
		    (Interv xmax xmin (recur t1 m t2))))
	       ))))
|#
)