;;
;;  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-2018 Ivan Raikov.
;;
;;  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 base))


;; 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 (< b a) (fold-for f b a e)
      (let recur ((i a) (res e))
	(if (<= i b) (recur (+ 1 i) (f i res))
	    res))))

	
(define (fold-for-down f a b e)
  (if (< a b) (fold-for-down f b a e)
      (let recur ((i a) (res e))
	(if (>= i b) (recur (- 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 ((> x1 x2)  #f)
			  ((> x2 x1)  (subset? t1 t2-tail))
			  (else (subset? t1-tail t2-tail))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((> x1 xmax2)  #f)
			  ((> 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 ((> x2 xmax1)  (subset? t1 t2-tail))
			  ((> xmin1 x2)  #f)
			  (else #f)))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((> xmin2 xmax1)  (subset? t1 t2-tail))
			  ((> xmin1 xmax2)  #f)
			  (else (and (>= xmax2 xmax1) (>= 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 (= x (+ 1 x1)) (Interv x x1 t1) (Single x t)))
	   ((Interv xmax1 xmin1 t1) 
	    (if (= x (+ 1 xmax1)) (Interv x xmin1 t1) (Single x t)))
	   ))


  (define (cons-interval xmax xmin t)
    (cond ((< xmax xmin) (cons-interval xmin xmax t))
	  ((= xmax xmin) (cons-single xmin t))
	  (else
	   (cases cis t
		  ((Nil) 
		   (Interv xmax xmin (Nil)))
		  ((Single x1 t1) 
		   (if (= xmin (+ 1 x1)) (Interv xmax x1 t1) (Interv xmax xmin t)))
		  ((Interv xmax1 xmin1 t1) 
		   (if (= xmin (+ 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 (+ 1 ax)))
	     ((Interv xmax1 xmin1 t1) (recur t1 (+ ax (+ 1 (- xmax1 xmin1)))))
	     )))
  

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


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


(define (interval xmin xmax)
  (cond ((> xmin xmax) (interval xmax xmin))
	((= 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 ((> x x1) (cons-single x t))
			       ((= x x1) t)
			       (else (cons-single x1 (add x t1)))))
	 ((Interv xmax1 xmin1 t1) (cond ((> x xmax1) (cons-single x t))
					((and (>= xmax1 x) (>= x xmin1)) t)
					(else (cons-interval xmax1 xmin1 (add x t1)))))
	   
	 ))



(define (remove x t)
  (cases cis t
	 ((Nil) empty)
	 ((Single x1 t1) 
	  (cond ((> x x1) t)
		((= x x1) t1)
		(else (cons-single x1 (remove x t1)))))
	 ((Interv xmax1 xmin1 t1) 
	  (cond ((> x xmax1) t)
		((= x xmin1)
		 (cons-interval xmax1 (+ 1 xmin1) t1))
		((= x xmax1)
		 (cons-interval (- xmax1 1) xmin1 t1))
		((and (> xmax1 x) (> x xmin1)) 
		 (cons-interval xmax1 (+ 1 x) (cons-interval (- 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 (<= 0 (+ m n))
	     (cases cis t
		    ((Nil) (Nil))
		    ((Single x1 t1)  (Single (+ x1 n) (shift n t1)))
		    ((Interv xmax1 xmin1 t1) 
		     (Interv (+ xmax1 n) (+ xmin1 n) (shift n t1)))
		    )))))
  
  

(define (union t1 t2)
  (cases cis t1
	 ((Nil) t2)
	 ((Single x1 t1-tail) 
	  (begin
	  (cases cis t2
		 ((Nil) t1)
		 ((Single x2 t2-tail) 
		  (cond ((> x1 (+ 1 x2))
			 (cons-single x1 (union t1-tail t2)))
			((> x2 (+ 1 x1))
			 (cons-single x2 (union t1 t2-tail)))
			((= x1 (+ 1 x2))
			 (cons-interval x1 x2 (union t1-tail t2-tail)))
			((= x2 (+ 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 ((> x1 xmax2) (cons-single x1 (union t1-tail t2)))
			  ((> xmin2 (+ 1 x1)) (cons-interval xmax2 xmin2 (union t1 t2-tail)))
			  ((= xmin2 (+ 1 x1)) (cons-interval xmax2 x1 (union t1-tail t2-tail)))
			  (else (cons-interval xmax2 x1 (union t1-tail (cons-interval (- x1 1) xmin2 t2-tail))))))
		 )))

	 ((Interv xmax1 xmin1 t1-tail) 
	  (cases cis t2
		 ((Nil) t1)
		 ((Single x2 t2-tail) 
		  (cond ((> x2 xmax1) (cons-single x2 (union t1 t2-tail)))
			((> xmin1 (+ 1 x2)) (cons-interval xmax1 xmin1 (union t1-tail t2)))
			((= xmin1 (+ 1 x2)) (cons-interval xmax1 x2 (union t1-tail t2-tail)))
			(else (cons-interval xmax1 x2 (union (cons-interval (- x2 1) xmin1 t1-tail) t2-tail)))))
		 ((Interv xmax2 xmin2 t2-tail) 
		  (cond ((> xmin2 xmax1) (cons-interval xmax2 xmin2 (union t1 t2-tail)))
			((> xmin1 xmax2) (cons-interval xmax1 xmin1 (union t1-tail t2)))
			(else (cons-interval (max xmax1 xmax2) (max xmin1 xmin2)
					     (cond ((= xmin1 xmin2) 
						    (union t1-tail t2-tail))
						   ((> xmin1 xmin2) 
						    (union t1-tail (cons-interval (- xmin1 1) xmin2 t2-tail)))
						   (else 
						    (union (cons-interval (- 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 ((> x1 (+ 1 x2))
			   (intersection t1-tail t2))
			  ((> x2 (+ 1 x1))
			   (intersection t1 t2-tail))
			  ((= x1 (+ 1 x2))
			   (intersection t1-tail t2-tail))
			  ((= x2 (+ 1 x1))
			   (intersection t1-tail t2-tail))
			  (else
			   (cons-single x1 (intersection t1-tail t2-tail)))
			  ))
		   ((Interv xmax2 xmin2 t2-tail) 
		    (cond ((> x1 xmax2) (intersection t1-tail t2))
			  ((> 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 ((> x2 xmax1)  (intersection t1 t2-tail))
			  ((> xmin1 x2)  (intersection t1-tail t2))
			  (else (cons-single x2 (intersection t1 t2-tail)))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((> xmin2 xmax1) (intersection t1 t2-tail))
			  ((> xmin1 xmax2) (intersection t1-tail t2))
			  (else (cons-interval (min xmax1 xmax2) (max xmin1 xmin2)
					       (if (>= 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 ((> x1 x2)  (cons-single x1 (difference t1-tail t2)))
			  ((> x2 x1)  (difference t1 t2-tail))
			  (else (difference t1-tail t2-tail))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((> x1 xmax2) (cons-single x1 (difference t1-tail t2)))
			  ((> 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 ((> x2 xmax1)  (difference t1 t2-tail))
			  ((> xmin1 x2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
			  (else  (cons-interval xmax1 (+ 1 x2) (difference (cons-interval (- x2 1) xmin1 t1-tail) 
									     t2-tail)))))
		   ((Interv xmax2 xmin2 t2-tail)
		    (cond ((> xmin2 xmax1)  (difference t1 t2-tail))
			  ((> xmin1 xmax2)  (cons-interval xmax1 xmin1 (difference t1-tail t2)))
			  (else
			   (cons-interval xmax1 (+ 1 xmax2)
					  (if (>= xmin1 xmin2)
					      (difference t1-tail t2)
					      (difference (cons-interval (- 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 (> x xmin) (inner (- 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 (= x (+ 1 m)) (cons-single x t2) (Single x t2))
		    (Single x (recur t1 m t2))))
	       ((Interv xmax xmin t1)
		(if (empty? t1)
		    (if (= xmin (+ 1 m)) (cons-interval xmax xmin t2) (Interv xmax xmin t2))
		    (Interv xmax xmin (recur t1 m t2))))
	       ))))
|#
)