natset.el

   1 (provide 'natset)
   2
   3 ;;; pacage for set of natural number.
   4 ;; (natural number includes zero.)
   5
   6 ;;; predicates
   7
   8 (defun natset-empty-p (ns)
   9   "Returns t if NS is empty."
  10   (equal ns ()))
  11
  12 (defun natset-full-p (ns)
  13   "Returns t if NS is full."
  14   (equal ns '(0)))
  15
  16 (defun natset-closed-p (ns)
  17   "Returns t if NS is closed."
  18   (= (logand (length ns) 1) 0))
  19
  20 (defun natset-open-p (ns)
  21   "Returns t if NS is open."
  22   (= (logand (length ns) 1) 1))
  23
  24 (defun natset-has-p (ns i)
  25   "Returns t if I is in NS."
  26   (not (natset-empty-p (natset-intersection (natset-single i) ns))))
  27
  28 (defun natset-has-intersection-p (ns1 ns2)
  29   "Returns t if the intersection of NS1 and NS2 is not empty."
  30   (not (natset-empty-p (natset-intersection ns1 ns2))))
  31
  32 (defun natset-include-p (ns1 ns2)
  33   "Returns t if NS1 includes NS2."
  34   (equal ns1 (natset-union ns1 ns2)))
  35
  36 ;;; accessor
  37
  38 (defun natset-start (ns)
  39   "Returns start element in NS."
  40   (if (natset-empty-p ns)
  41       (error "natset empty" ns))
  42   (car ns))
  43
  44 ;;; primitive constructor
  45
  46 (defun natset-empty ()
  47   "Returns a empty set.
  48 {}"
  49   ())
  50
  51 (defun natset-full ()
  52   "Returns a full set.
  53 {i | 0 <= i}"
  54   '(0))
  55
  56 (defun natset-single (&rest elts)
  57   "Returns a set contains singleton elements.
  58 {i | i in ELTS}"
  59   (let ((ns (natset-empty)))
  60     (while elts
  61       (setq ns (natset-union ns (natset-seg (car elts) (car elts)))
  62             elts (cdr elts)))
  63     ns))
  64
  65 (defun natset-seg (start &optional end)
  66   "Returns a set contains one segment.
  67 {i | START <= i and i <= END}
  68
  69 If END is nil, Return the set {i | START <= i}"
  70   (if end
  71       (list start (1+ end))
  72     (list start)))
  73
  74 ;;; complex constructor
  75
  76 (defun natset-start-set (ns)
  77   "Returns a set contains start boundaries for NS.
  78 {i | NS does not contains i-1 and NS contains i}"
  79   (let ((res ()))
  80     (while ns
  81       (setq res (cons (1+ (car ns)) (cons (car ns) res))
  82             ns (cddr ns)))
  83     (nreverse res)))
  84
  85 (defun natset-end-set (ns)
  86   "Returns a set contains end boundaries for NS.
  87 {i | NS contains i-1 and NS does not contains i}"
  88   (let ((res ()))
  89     (setq ns (cdr ns))
  90     (while ns
  91       (setq res (cons (1+ (car ns)) (cons (car ns) res))
  92             ns (cddr ns)))
  93     (nreverse res)))
  94
  95 (defun natset-boundary-set (ns)
  96   "Returns a set contains start and end boundaries for NS.
  97 {i | NS contains i-1 xor NS does not contains i}"
  98   (natset-union (natset-start-set ns) (natset-end-set ns)))
  99
 100 (defun natset-minmax (ns)
 101   "Returns a set contains a range from minimum to maximam of NS.
 102 {i | There exists j, k in NS, j <= i <= k}"
 103   (cond
 104    ((null ns) ())
 105    ((natset-open-p ns) (list (car ns)))
 106    (t
 107     (list (car ns) (nth (1- (length ns)) ns)))))
 108
 109 ;;; set operation
 110
 111 (defun natset-negate (ns)
 112   "Returns negated set.
 113 {i | 0 <= i and NS does not contains i}"
 114   (if (and (consp ns) (= (car ns) 0))
 115       (cdr ns)
 116     (cons 0 ns)))
 117
 118 (defun natset-union (&rest nss)
 119   "Returns unioned set.
 120 {i | There exists ns in NSS s.t ns contains i}"
 121   (let ((ns (natset-empty)))
 122     (while nss
 123       (setq ns (natset-union2 ns (car nss))
 124             nss (cdr nss)))
 125     ns))
 126
 127 (defun natset-intersection (&rest nss)
 128   "Returns intersectioned set.
 129 {i | For all ns in NSS, ns contains i}"
 130   (natset-negate (apply 'natset-union (mapcar 'natset-negate nss))))
 131
 132 (defun natset-sub (ns &rest nss)
 133   "Returns subtracted set.
 134 {i | NS contains i and for all ns in NSS, ns does not contains i}"
 135   (setq ns (natset-intersection ns (natset-negate (apply 'natset-union nss)))))
 136
 137 ;;; enumeration
 138
 139 (defun natset-enum (ns)
 140   (if (natset-open-p ns)
 141       (error "natset open" ns))
 142   (let ((res ()) i j)
 143     (while ns
 144       (setq i (car ns)
 145             j (cadr ns)
 146             ns (cddr ns))
 147       (while (< i j)
 148         (setq res (cons i res)
 149               i (1+ i))))
 150     (nreverse res)))
 151
 152 ;;; code generation
 153
 154 (defun natset-take-seg (ns)
 155   (cond
 156    ((null ns) (error "NS empty" ns))
 157    ((null (cdr ns)) (cons ns ()))
 158    (t (cons (list (car ns) (cadr ns)) (cddr ns)))))
 159
 160 (defun natset-valid-filter (ns valid)
 161   "Returns a filtered set R.
 162 R includes intersection between VALID and NS.
 163 R does not include intersecton between VALID and negated NS.
 164 Element does not contained in VALID is unspecified."
 165   (let* ((res (natset-intersection valid ns))
 166          (len (length res))
 167          (u-set (natset-negate valid))
 168          tmp1 tmp2 tmpl)
 169     (while u-set
 170       (setq tmp1 (natset-take-seg u-set))
 171       (setq tmp2 (natset-union (car tmp1) res)
 172             tmpl (length tmp2))
 173       (if (or (< tmpl len) (and (= tmpl len) (equal 0 (car tmp2))))
 174           (setq res tmp2
 175                 len (length tmp2)))
 176       (setq u-set (cdr tmp1)))
 177     res))
 178
 179 (defun natset-gen-pred-exp (ns var &optional valid)
 180   "Returns a expression to test value of variable VAR is in NS or not.
 181
 182 If VALID is not nil, the condition value of VAR is in VALID is assumed.
 183 It is impossible to set VALID to empty set because empty set is represented as nil."
 184   (if valid (setq ns (natset-valid-filter ns valid)))
 185   (cond
 186    ((null ns) nil)
 187    ((= (car ns) 0) (natset-gen-pred-exp-internal (cdr ns) var nil 0))
 188    (t (natset-gen-pred-exp-internal ns var t 0))))
 189
 190 ;;; internal primitive
 191
 192 (defun natset-union2 (ns1 ns2)
 193   (let (res start (end t))
 194     (while (and end (or (consp ns1) (consp ns2)))
 195       (if (and (consp ns1) (or (null ns2) (<= (car ns1) (car ns2))))
 196           (setq start (car ns1)
 197                 end (cadr ns1)
 198                 ns1 (cddr ns1))
 199         (setq start (car ns2)
 200               end (cadr ns2)
 201               ns2 (cddr ns2)))
 202       (while (and end
 203                   (or (and (consp ns1) (<= (car ns1) end))
 204                       (and (consp ns2) (<= (car ns2) end))))
 205         (if (and (consp ns1) (<= (car ns1) end))
 206             (progn
 207               (if (or (null (cadr ns1)) (< end (cadr ns1))) (setq end (cadr ns1)))
 208               (setq ns1 (cddr ns1)))
 209           (progn
 210             (if (or (null (cadr ns2)) (< end (cadr ns2))) (setq end (cadr ns2)))
 211             (setq ns2 (cddr ns2)))))
 212       (setq res (cons start res))
 213       (if end (setq res (cons end res))))
 214     (nreverse res)))
 215
 216 ; n is greater or equal 2.
 217 ; returns one of 1 .. n-1
 218 ; (In reality, returns greatest 2^i - 1)
 219 (defun natset-divide (n)
 220   (let ((l 2) tmp)
 221     (while (< (setq tmp (lsh l 1)) n)
 222       (setq l tmp))
 223     (1- l)))
 224
 225 (defun natset-gen-pred-exp-internal (ns var bool base)
 226   (cond
 227    ((null ns) (not bool))
 228    ((null (cdr ns))
 229     (if (<= (car ns) base)
 230         bool
 231       (if bool `(<= ,(car ns) ,var) `(< ,var ,(car ns)))))
 232    (t
 233     (let* ((div (natset-divide (length ns)))
 234            (l (append ns ()))
 235            (g (nthcdr (1- div) l))
 236            (m (cadr g))
 237            )
 238       (setq g (prog1 (cddr g) (setcdr g ())))
 239       `(if (< ,var ,m)
 240            ,(natset-gen-pred-exp-internal l var bool base)
 241          ,(natset-gen-pred-exp-internal
 242            g var (if (= (logand div 1) 1) bool (not bool)) m))))))