rx.el

   1 ;;; regular expression
   2
   3 ;;; core
   4 ;; rx ::= []                  {}
   5 ;;      | ()                  {""}
   6 ;;      | (* . rx)            closure
   7 ;;      | (| . rxs)           alternative
   8 ;;      | (rx . rx)           concatination
   9 ;;      | (cc c1 c2 c3 ...)   character class (natset)
  10 ;;; sugar
  11 ;;      | (+ . rx)            positive closure
  12 ;;      | "..."               string
  13 ;;      | c                   character
  14 ;;      | (non-ascii)         (cc 128)
  15 ;;      | [ range ... ]
  16 ;;      | [ ^ range ... ]
  17 ;;; internal
  18 ;;      | pc                  primitive character class
  19 ;;      | (act . int)         action
  20
  21 ;; range ::= c
  22 ;;        | "..."
  23 ;;        | (c1 c2)           [c1 c2]
  24 ;;        | (c1 . c2)         [c1 c2)
  25 ;;        | (c)               [c1 inf)
  26 ;;        | non-ascii
  27
  28 (require 'natset)
  29 (require 'automata)
  30 (provide 'rx)
  31
  32 (defun rx-empty-p (rx) (equal rx []))
  33 (defun rx-null-p (rx) (equal rx ()))
  34 (defun rx-act-p (rx) (and (consp rx) (eq (car rx) 'act)))
  35 (defun rx-cc-p (rx) (and (consp rx) (eq (car rx) 'cc)))
  36 (defalias 'rx-pc-p 'integerp)
  37
  38 (defun rx-clo-p (rx) (and (consp rx) (eq (car rx) '*)))
  39 (defun rx-alt-p (rx) (and (consp rx) (eq (car rx) '|)))
  40 (defun rx-con-p (rx) (and (consp rx) (or (null (car rx)) (not (symbolp (car rx))))))
  41
  42 (defun rx-clo (rx)
  43   (cond
  44    ((rx-empty-p rx) ())
  45    ((rx-null-p rx) rx)
  46    ((rx-act-p rx) rx)
  47    ((rx-clo-p rx) rx)
  48    (t (cons '* rx))))
  49 (defun rx-alt (rxs)
  50   (cond
  51    ((null rxs) [])
  52    ((null (cdr rxs)) (car rxs))
  53    (t (cons '| rxs))))
  54 (defun rx-alt2 (r1 r2)
  55   (cond
  56    ((rx-empty-p r1) r2)
  57    ((rx-empty-p r2) r1)
  58    ((equal r1 r2) r1)
  59    (t (list '| r1 r2))))
  60 (defun rx-con (r1 r2)
  61   (cond
  62    ((rx-empty-p r1) [])
  63    ((rx-empty-p r2) [])
  64    ((rx-null-p r1) r2)
  65    ((rx-null-p r2) r1)
  66    ((and (rx-act-p r1) (rx-act-p r2)) r2)
  67    (t (cons r1 r2))))
  68 (defun rx-act (obj) (cons 'act obj))
  69 (defun rx-cc (cs) (cons 'cc cs))
  70
  71 ;;; regular expression preprocessing
  72
  73 (defun rx-range-to-ns (range)
  74   (cond
  75    ((char-or-char-int-p range)
  76     (natset-single (char-int range)))
  77    ((stringp range)
  78     (let ((ns (natset-empty)) (chars (string-to-int-list range)))
  79       (while chars
  80         (setq ns (natset-union ns (natset-single (car chars)))
  81               chars (cdr chars)))
  82       ns))
  83    ((eq range 'non-ascii)
  84     (natset-seg 128))
  85    ((and (consp range)
  86          (null (cdr range))
  87          (char-or-char-int-p (car range)))
  88     (natset-seg (car range)))
  89    ((and (consp range)
  90          (consp (cdr range))
  91          (null (cddr range))
  92          (char-or-char-int-p (car range))
  93          (char-or-char-int-p (cadr range)))
  94     (natset-seg (char-int (car range)) (char-int (cadr range))))
  95    ((and (consp range)
  96          (char-or-char-int-p (car range))
  97          (char-or-char-int-p (cdr range)))
  98     (natset-seg (char-int (car range)) (1- (char-int (cdr range)))))
  99    (t (error "not range %s" range))))
 100
 101 (defun rx-vcc-to-rx (vcc)
 102   (let ((l (append vcc ())) neg ns)
 103     (if (eq (car l) '^)
 104         (setq l (cdr l)
 105               neg t))
 106     (setq l (mapcar 'rx-range-to-ns l))
 107     (setq ns (natset-empty))
 108     (while l
 109       (setq ns (natset-union ns (car l))
 110             l (cdr l)))
 111     (if neg (setq ns (natset-negate ns)))
 112     (if (natset-empty-p ns)
 113         []
 114       (rx-cc ns))))
 115
 116 (defun rx-desugar (rx)
 117   (cond
 118    ((stringp rx) (rx-desugar (string-to-int-list rx)))
 119    ((vectorp rx) (rx-vcc-to-rx rx))
 120    ((char-or-char-int-p rx) (rx-cc (natset-single (char-int rx))))
 121    ((and (consp rx) (eq (car rx) '+)) (let ((r (rx-desugar (cdr rx)))) (rx-con r (rx-clo r))))
 122    ((and (consp rx) (eq (car rx) 'non-ascii)) (rx-cc (natset-seg 128)))
 123    ((and (consp rx) (eq (car rx) 'any)) (rx-cc (natset-full)))
 124    ((rx-empty-p rx) rx)
 125    ((rx-null-p rx) rx)
 126    ((rx-act-p rx) rx)
 127    ((rx-cc-p rx) rx)
 128    ((rx-clo-p rx) (rx-clo (rx-desugar (cdr rx))))
 129    ((rx-alt-p rx) (rx-alt (mapcar 'rx-desugar (cdr rx))))
 130    ((rx-con-p rx) (rx-con (rx-desugar (car rx)) (rx-desugar (cdr rx))))
 131    (t (error "not rx %s" rx))))
 132
 133 (defun rx-collect-cc (rx &optional cs)
 134   (cond
 135    ((rx-empty-p rx) cs)
 136    ((rx-null-p rx) cs)
 137    ((rx-act-p rx) cs)
 138    ((rx-cc-p rx) (append (cdr rx) cs))
 139    ((rx-clo-p rx) (rx-collect-cc (cdr rx) cs))
 140    ((rx-alt-p rx)
 141     (setq rx (cdr rx))
 142     (while (consp rx)
 143       (setq cs (rx-collect-cc (car rx) cs)
 144             rx (cdr rx)))
 145     cs)
 146    ((rx-con-p rx) (rx-collect-cc (car rx) (rx-collect-cc (cdr rx) cs)))
 147    (t (error "not rx %s" rx))))
 148
 149 (defun rx-cc-to-pc (rx cs)
 150   (cond
 151    ((rx-empty-p rx) rx)
 152    ((rx-null-p rx) rx)
 153    ((rx-act-p rx) rx)
 154    ((rx-cc-p rx)
 155     (setq rx (cdr rx))
 156     (let (res)
 157       (while (and (consp rx) (consp (cdr rx)))
 158         (let ((start (car rx)) (end (cadr rx)))
 159           (setq res (rx-filter (lambda (c) (and (<= start c) (< c end))) cs res)
 160                 rx (cddr rx))))
 161       (if (consp rx)
 162           (let ((start (car rx)))
 163             (setq res (rx-filter (lambda (c) (<= start c)) cs res))))
 164       (rx-alt (rx-sort-int res))))
 165    ((rx-clo-p rx) (rx-clo (rx-cc-to-pc (cdr rx) cs)))
 166    ((rx-alt-p rx) (rx-alt (mapcar (lambda (r) (rx-cc-to-pc r cs)) (cdr rx))))
 167    ((rx-con-p rx) (rx-con (rx-cc-to-pc (car rx) cs) (rx-cc-to-pc (cdr rx) cs)))
 168    (t (error "not rx %s" rx))))
 169
 170 (defun rx-categolize-char (rx)
 171   (let ((cs (rx-sort-int (rx-collect-cc rx))))
 172     (cons
 173      (rx-cc-to-pc rx cs)
 174      cs)))
 175
 176 ;;; simplification
 177
 178 (defun rx-nullable-p (rx)
 179   (cond
 180    ((rx-empty-p rx) nil)
 181    ((rx-null-p rx) t)
 182    ((rx-act-p rx) t)
 183    ((rx-pc-p rx) nil)
 184    ((rx-clo-p rx) t)
 185    ((rx-alt-p rx)
 186     (setq rx (cdr rx))
 187     (while (and (consp rx) (not (rx-nullable-p (car rx))))
 188       (setq rx (cdr rx)))
 189     (consp rx))
 190    ((rx-con-p rx)
 191     (and (rx-nullable-p (car rx)) (rx-nullable-p (cdr rx))))
 192    (t (error "not rx %s" rx))))
 193
 194 (defun rx-simplify (rx)
 195   (cond
 196    ((rx-empty-p rx) rx)
 197    ((rx-null-p rx) rx)
 198    ((rx-act-p rx) rx)
 199    ((rx-pc-p rx) rx)
 200    ((rx-clo-p rx)
 201     (rx-clo (rx-simplify (cdr rx))))
 202    ((rx-alt-p rx)
 203     (let ((in (cdr rx)) (out ())
 204           already-simplified-list already-simplified)
 205       (while (consp in)
 206         (setq rx (car in)
 207               in (cdr in)
 208               already-simplified (car already-simplified-list)
 209               already-simplified-list (cdr already-simplified-list))
 210         (if (rx-alt-p rx)
 211             (setq in (append (cdr rx) in))
 212           (progn
 213             (setq rx (if already-simplified rx (rx-simplify rx)))
 214             (cond
 215              ((rx-empty-p rx)) ; [] is identity element for alternation.
 216              ((rx-alt-p rx)
 217               (setq in (append (cdr rx) in)
 218                     already-simplified-list (append (make-list (length (cdr rx)) nil) already-simplified-list)))
 219              ((not (member rx out))
 220               (setq out (cons rx out)))))))
 221       (rx-alt (rx-sort-rx (reverse out)))))
 222    ((rx-con-p rx)
 223     (catch 'return
 224       (let ((in (list (car rx) (cdr rx))) (out ())
 225             already-simplified-list already-simplified)
 226         (while (consp in)
 227           (setq rx (car in)
 228                 in (cdr in)
 229                 already-simplified (car already-simplified-list)
 230                 already-simplified-list (cdr already-simplified-list))
 231           (if (rx-con-p rx)
 232               (setq in (rx-cons* (car rx) (cdr rx) in))
 233             (progn
 234               (setq rx (if already-simplified rx (rx-simplify rx)))
 235               (cond
 236                ((rx-empty-p rx) ; [] is zero element for concatination.
 237                 (throw 'return []))
 238                ((rx-null-p rx)) ; () is identity element for concatination.
 239                ((rx-con-p rx)
 240                 (setq in (rx-cons* (car rx) (cdr rx) in))
 241                       already-simplified-list (rx-cons* t t already-simplified-list))
 242                (t
 243                 (setq out (cons rx out)))))))
 244         (if (= (length out) 1)
 245             (car out)
 246           (nreverse out)))))
 247    (t (error "not rx %s" rx))))
 248
 249 ;;; head property
 250
 251 (defun rx-head-pcs (rx &optional res)
 252   (cond
 253    ((rx-empty-p rx) res)
 254    ((rx-null-p rx) res)
 255    ((rx-act-p rx) res)
 256    ((rx-pc-p rx) (if (member rx res) res (cons rx res)))
 257    ((rx-clo-p rx) (rx-head-pcs (cdr rx) res))
 258    ((rx-alt-p rx)
 259     (setq rx (cdr rx))
 260     (while (consp rx)
 261       (setq res (rx-head-pcs (car rx) res)
 262             rx (cdr rx)))
 263     res)
 264    ((rx-con-p rx)
 265     (setq res (rx-head-pcs (car rx) res))
 266     (if (rx-nullable-p (car rx))
 267         (setq res (rx-head-pcs (cdr rx) res)))
 268     res)
 269    (t (error "not rx %s" rx))))
 270
 271 (defun rx-head-act (rx &optional res)
 272   (cond
 273    ((rx-empty-p rx) res)
 274    ((rx-null-p rx) res)
 275    ((rx-act-p rx) (rx-better-act rx res))
 276    ((rx-pc-p rx) res)
 277    ((rx-clo-p rx) (rx-head-act (cdr rx) res))
 278    ((rx-alt-p rx)
 279     (setq rx (cdr rx))
 280     (while (consp rx)
 281       (setq res (rx-head-act (car rx) res)
 282             rx (cdr rx)))
 283     res)
 284    ((rx-con-p rx)
 285     (setq res (rx-head-act (car rx) res))
 286     (if (rx-nullable-p (car rx))
 287         (setq res (rx-head-act (cdr rx) res)))
 288     res)
 289    (t (error "not rx %s" rx))))
 290
 291 ;;; stepping
 292
 293 (defun rx-step-internal (rx pc)
 294   (cond
 295    ((rx-empty-p rx) [])
 296    ((rx-null-p rx) [])
 297    ((rx-act-p rx) [])
 298    ((rx-pc-p rx) (if (= rx pc) () []))
 299    ((rx-clo-p rx) (rx-con (rx-step-internal (cdr rx) pc) rx))
 300    ((rx-alt-p rx) (rx-alt (mapcar (lambda (r) (rx-step-internal r pc)) (cdr rx))))
 301    ((rx-con-p rx)
 302     (if (rx-nullable-p (car rx))
 303         (rx-alt2
 304          (rx-con (rx-step-internal (car rx) pc) (cdr rx))
 305          (rx-step-internal (cdr rx) pc))
 306       (rx-con (rx-step-internal (car rx) pc) (cdr rx))))
 307    (t (error "not rx %s" rx))))
 308
 309 (defun rx-step (rx &rest pcs)
 310   (while (consp pcs)
 311     (setq rx (rx-simplify (rx-step-internal rx (car pcs)))
 312           pcs (cdr pcs)))
 313   rx)
 314
 315 ;;; utilities
 316
 317 (defun rx-better-act (a1 a2)
 318   (cond
 319    ((null a2) a1)
 320    ((< (cdr a1) (cdr a2)) a1)
 321    (t a2)))
 322
 323 (defun rx-cons* (elt &rest lst)
 324   (if (null lst)
 325       elt
 326     (cons elt (apply 'rx-cons* (car lst) (cdr lst)))))
 327
 328 (defun rx-filter (fun lst &optional rest)
 329   (if (null lst)
 330       rest
 331     (if (funcall fun (car lst))
 332         (cons (car lst) (rx-filter fun (cdr lst) rest))
 333       (rx-filter fun (cdr lst) rest))))
 334
 335 (defun rx-cmp-index (rx)
 336   (cond
 337    ((rx-null-p rx) (list 0))
 338    ((rx-act-p rx) (list 1 (cdr rx)))
 339    ((rx-empty-p rx) (list 2))
 340    ((rx-clo-p rx) (list 3 (cdr rx)))
 341    ((rx-alt-p rx) (cons 4 (cdr rx)))
 342    ((rx-con-p rx) (list 5 (car rx) (cdr rx)))
 343    ((rx-pc-p rx) (list 6 rx))
 344    (t (error "not rx %s" rx))))
 345
 346 (defun rx-cmp-int (i1 i2)
 347   (cond
 348    ((< i1 i2) -1)
 349    ((> i1 i2) 1)
 350    (t 0)))
 351
 352 (defun rx-cmp-rx (r1 r2)
 353   (let ((i1 (rx-cmp-index r1)) (i2 (rx-cmp-index r2)))
 354      (cond
 355       ((< (car i1) (car i2)) -1)
 356       ((> (car i1) (car i2)) 1)
 357       (t (setq i1 (cdr i1)
 358                i2 (cdr i2))
 359          (catch 'result
 360            (while (and (consp i1) (consp i2))
 361              (let ((r (if (and (integerp (car i1)) (integerp (car i2)))
 362                           (rx-cmp-int (car i1) (car i2))
 363                         (rx-cmp-rx (car i1) (car i2)))))
 364                (if (not (zerop r))
 365                    (throw 'result r)
 366                  (setq i1 (cdr i1)
 367                        i2 (cdr i2)))))
 368            (if (null i1) (if (null i2) 0 -1) 1))))))
 369
 370 (defun rx-sort-rx (l &optional res)
 371   (if (null l)
 372       res
 373     (let ((e (car l)) lt gt cmp)
 374       (setq l (cdr l))
 375       (while (consp l)
 376         (setq cmp (rx-cmp-rx (car l) e))
 377         (cond
 378          ((< cmp 0) (setq lt (cons (car l) lt)))
 379          ((< 0 cmp) (setq gt (cons (car l) gt))))
 380         (setq l (cdr l)))
 381       (rx-sort-rx lt (cons e (rx-sort-rx gt res))))))
 382
 383 (defun rx-sort-int (l &optional res)
 384   (if (null l)
 385       res
 386     (let ((e (car l)) lt gt)
 387       (setq l (cdr l))
 388       (while (consp l)
 389         (cond
 390          ((< (car l) e) (setq lt (cons (car l) lt)))
 391          ((< e (car l)) (setq gt (cons (car l) gt))))
 392         (setq l (cdr l)))
 393       (rx-sort-int lt (cons e (rx-sort-int gt res))))))
 394