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 (defun natset-gen-ccl-branch256 (reg fail &rest clauses)
 191   (let ((i 255) tmp blocks)
 192     (while (<= 0 i)
 193       (setq blocks (cons
 194                      (if (setq tmp (natset-assoc i clauses))
 195                        (cdr tmp)
 196                        fail)
 197                      blocks)
 198             i (1- i)))
 199     `(branch ,reg ,@blocks)))
 200
 201 (defun natset-gen-ccl-branch (reg fail &rest clauses)
 202   (let* ((natsets (mapcar 'car clauses)))
 203     (let ((range (apply 'natset-union natsets)) tmp)
 204       (unless (natset-empty-p range)
 205         (setq natsets (cons (natset-negate range)
 206                             natsets)
 207               clauses (cons (cons (car natsets)
 208                                   fail)
 209                             clauses)))
 210       (setq range (natset-full)
 211             tmp natsets)
 212       (while tmp
 213         (setcar tmp
 214                 (natset-intersection
 215                  (car tmp)
 216                  range))
 217         (setq range (natset-sub range (car tmp))
 218               tmp (cdr tmp))))
 219     (let ((b (natset-enum
 220               (natset-sub
 221                (apply
 222                 'natset-union
 223                 (mapcar
 224                  'natset-boundary-set
 225                  natsets))
 226                (natset-single 0)))))
 227       (natset-gen-ccl-branch-internal reg 0 b clauses))))
 228
 229 (defun natset-gen-ccl-branch-internal (reg s b clauses)
 230   (cond
 231    ((null b)
 232     (cdr (natset-assoc s clauses)))
 233    ((null (cdr b))
 234     `(if (,reg < ,(car b))
 235          ,(cdr (natset-assoc s clauses))
 236        ,(cdr (natset-assoc (car b) clauses))))
 237    (t
 238     (let* ((div (natset-divide (length b)))
 239            (l (append b ()))
 240            (g (nthcdr (1- div) l))
 241            (m (cadr g)))
 242       (setq g (prog1 (cddr g) (setcdr g ())))
 243       `(if (,reg < ,m)
 244            ,(natset-gen-ccl-branch-internal reg s l clauses)
 245          ,(natset-gen-ccl-branch-internal reg m g clauses))))))
 246
 247 (defun natset-assoc (key alist)
 248   (catch 'return
 249     (while alist
 250       (when (natset-has-p (caar alist) key)
 251         (throw 'return (car alist)))
 252       (setq alist (cdr alist)))
 253     nil))
 254
 255 ;;; internal primitive
 256
 257 (defun natset-union2 (ns1 ns2)
 258   (let (res start (end t))
 259     (while (and end (or (consp ns1) (consp ns2)))
 260       (if (and (consp ns1) (or (null ns2) (<= (car ns1) (car ns2))))
 261           (setq start (car ns1)
 262                 end (cadr ns1)
 263                 ns1 (cddr ns1))
 264         (setq start (car ns2)
 265               end (cadr ns2)
 266               ns2 (cddr ns2)))
 267       (while (and end
 268                   (or (and (consp ns1) (<= (car ns1) end))
 269                       (and (consp ns2) (<= (car ns2) end))))
 270         (if (and (consp ns1) (<= (car ns1) end))
 271             (progn
 272               (if (or (null (cadr ns1)) (< end (cadr ns1))) (setq end (cadr ns1)))
 273               (setq ns1 (cddr ns1)))
 274           (progn
 275             (if (or (null (cadr ns2)) (< end (cadr ns2))) (setq end (cadr ns2)))
 276             (setq ns2 (cddr ns2)))))
 277       (setq res (cons start res))
 278       (if end (setq res (cons end res))))
 279     (nreverse res)))
 280
 281 ; n is greater or equal 2.
 282 ; returns one of 1 .. n-1
 283 ; (In reality, returns greatest 2^i - 1)
 284 (defun natset-divide (n)
 285   (let ((l 2) tmp)
 286     (while (< (setq tmp (lsh l 1)) n)
 287       (setq l tmp))
 288     (1- l)))
 289
 290 (defun natset-gen-pred-exp-internal (ns var bool base)
 291   (cond
 292    ((null ns) (not bool))
 293    ((null (cdr ns))
 294     (if (<= (car ns) base)
 295         bool
 296       (if bool `(<= ,(car ns) ,var) `(< ,var ,(car ns)))))
 297    (t
 298     (let* ((div (natset-divide (length ns)))
 299            (l (append ns ()))
 300            (g (nthcdr (1- div) l))
 301            (m (cadr g))
 302            )
 303       (setq g (prog1 (cddr g) (setcdr g ())))
 304       `(if (< ,var ,m)
 305            ,(natset-gen-pred-exp-internal l var bool base)
 306          ,(natset-gen-pred-exp-internal
 307            g var (if (= (logand div 1) 1) bool (not bool)) m))))))