(defpackage :foo
  (:use :common-lisp))

(in-package :foo)

;;;; -- Interval Sums -------------------------------------------------------------------------

;; To support large character sets, we need an implemention of a set of
;; characters. Traditional scanner generators would at some place just
;; enumerate the alphabet \Sigma, which is not feasible with large character
;; sets like Unicode.

;; We handle all transitions in the automaton as a set of of the codes of
;; characters, expressed by an ISUM. The representation of such a set is
;; best defined by the ISUM-MEMBER function, but here is an overview to get
;; the idea:

;;     NIL          is the empty set
;;     (a b)        is the set [a, b)
;;     (a b c d)    is the set [a, b) u [c, d)
;;     (nil)        is everything
;;     (nil a b)    is everything but [a, b)

;; An ISUM is a sequence of stricly monotonic increasing integers. The idea
;; is that when you sweep a pointer over the list at each element found the
;; membership in the set changes. Like (1 10 12 15). You start outside the
;; set, find 1 and say "above or equal 1 is in the set" and then find 10 and
;; say "above or equal 10 is not in the set" and so on. This way it is very
;; easy to implement Boolean operations on sets.

(defmacro define-constant (&rest xs)
  ;; Common Lisps defconst is borken.
  `(defparameter ,@xs))

(define-constant +isum-nothing+ nil
  "The empty set.")

(define-constant +isum-everything+ '(nil)
  "The set that contains every integer.")

(define-constant +isum-any-character+ (list 0 char-code-limit)
  "The set that contains every character by its code point.")

(define-constant +isum-ascii-printable+ (list 32 128))

(defun isum-singleton (x)
  "Returns the ISUM, that contains only /x/."
  (list x (1+ x)))

(defun isum-range (from below)
  "Returns the ISUM, that contains every code point that is in [from, below)"
  (list from below))

;;; Membership

(defun isum-member (x isum)
  "Determines, whether /x/ is member of the ISUM /isum/. Returns non-NIL if so and NIL otherwise."
  (declare (type fixnum x)
           (optimize (speed 3) (safety 0)))
  (loop for i of-type fixnum from 0
     for y in isum
     when (and y (< x (the fixnum y))) return (oddp i)
     finally (return (oddp i))))

;;; Boolean operation on ISUMs

(defmacro isum-op (op A B)
  "Combine the sets A and B by the Boolean operator op, which should be a
valid argument to the BOOLE function. An integer x is member of the
resulting set iff
     (logbitp 0 (boole op (if (isum-member x A) 1 0) (if (isum-member x B) 1 0)))
 is non-NIL. That way e.g. boole-ior denotes the union."
  `((lambda (A B)
      (declare (optimize (speed 3) (safety 0)))
      (let* ((Ain 0)
             (Bin 0)
             (Cin 0)
             (s nil)
             (res (cons nil nil))
             (resf res))
        (declare (type fixnum Ain Bin Cin)
                 (type cons res))
        ;; Get rid of an initial NIL, which indicates a complemented set.
        (when (and A (null (car A)))
          (pop A) (setq Ain (- 1 Ain)))
        (when (and B (null (car B)))
          (pop B) (setq Bin (- 1 Bin)))
        ;; Now traverse A and B in paralell and generate the resulting sequence.
        (loop
           (when (/= Cin
                     (the fixnum (ldb (byte 1 0) (the fixnum (boole ,op (the fixnum Ain) (the fixnum Bin))))))
             (setf resf (setf (cdr resf) (cons s nil)))
             (setf Cin (the fixnum (- 1 Cin))))
           (cond ((null A)
                  (cond ((null B)
                         (return))
                        (t
                         (setq s (pop B))
                         (setq Bin (the fixnum (- 1 Bin))))))
                 ((null B)
                  (setq s (pop A)) (setq Ain (the fixnum (- 1 Ain))))
                 ((< (the fixnum (car A)) (the fixnum (car B)))
                  (setq s (pop A)) (setq Ain (the fixnum (- 1 Ain))))
                 ((< (the fixnum (car B)) (the fixnum (car A)))
                  (setq s (pop B)) (setq Bin (the fixnum (- 1 Bin))))
                 (t
                  (setq s (pop A)) (setq Ain (the fixnum (- 1 Ain)))
                  (pop B) (setq Bin (the fixnum (- 1 Bin)))) ))
        (cdr res)))
    ,A ,B))

;;; Boiler plate

;; Now we could define interesting set operations in terms of ISUM-OP.

(defun isum-union (a b)         (isum-op boole-ior a b))
(defun isum-intersection (a b)  (isum-op boole-and a b))
(defun isum-difference (a b)    (isum-op boole-andc2 a b))
(defun isum-complement (a)      (isum-op boole-c1 a nil))

;;; Misc

(defun isum-witness (isum)
  "Returns a witness of the set /isum/, which must be non empty."
  (cond ((null isum)
         (error "The empty set has no witnesses."))
        ((null (car isum))
         (if (cdr isum)
             (1- (cadr isum))
             42))                       ;you get it
        (t
         (car isum))))

(defun isum-empty-p (isum)
  (null isum))

;;;; ------------------------------------------------------------------------------------------

(defmacro isum-case (var &body clauses)
  ;; A variation on the theme, actually this is of more general use, since
  ;; Common Lisp implementations lack a jump table based implementation of
  ;; CASE.
  (let* ((last-out nil)
         (res nil)
         (default (find t clauses :key #'car))
         (clauses (remove default clauses))
         (clauses (mapcar (lambda (clause)
                            (cond ((integerp (car clause))
                                   (cons (list (car clause) (1+ (car clause)))
                                         (cdr clause)))
                                  (t clause)))
                          clauses)))
    (assert (every #'evenp (mapcar #'length (mapcar #'car clauses))))
    (loop do
         (when (every #'null (mapcar #'car clauses))
           (return))
         (let ((pivot (reduce #'min (remove nil (mapcar #'caar clauses)))))
           (setf clauses (mapcar (lambda (y)
                                   (if (eql (caar y) pivot) (cons (cdar y) (cdr y)) y))
                                 clauses))
           (let ((out (or (find-if (lambda (y) (oddp (length (car y)))) clauses)
                          default)))
             (unless (equal (cdr out) last-out)
               (push pivot res)
               (push (if (null (cddr out)) (cadr out) `(progn ,@(cdr out)))
                     res)
               (setf last-out (cdr out))))))
    (labels ((cons-if (cond cons alt)
               (cond ((null cons) `(unless ,cond ,alt))
                     ((null alt)  `(when ,cond ,cons))
                     (t           `(if ,cond ,cons ,alt))))
             (cons-progn (x)
               (if (null (cdr x))
                   (car x)
                   `(progn ,@x)))
             (foo (xs default)
               (cond ((null xs) default)
                     ((= 2 (length xs))
                      (cons-if `(< ,var ,(first xs)) default (second xs)))
                     (t
                      (let ((p (* 2 (floor (length xs) 4))))
                        (cons-if `(< ,var ,(elt xs p))
                                 (foo (subseq xs 0 p) default)
                                 (foo (subseq xs (+ 2 p)) (elt xs (1+ p)))))))))
      (foo (reverse res) (cons-progn (cdr default))))))