automata.el

   1
   2 (require 'digraph)
   3 (require 'natset)
   4 (provide 'automata)
   5
   6 (defvar automata-never-fail (make-symbol "automata-never-fail"))
   7 (defvar automata-state-var (make-symbol "automata-state"))
   8
   9 (defmacro automata (in-var start-tag &rest clauses)
  10   (let* ((org-len (length clauses))
  11          (org-graph (make-vector org-len nil))
  12          (tag-to-org-alist nil)
  13          forest org-to-forest forest-to-org
  14          i j tmp trans)
  15     (setq tmp clauses
  16           i 0)
  17     (while tmp
  18       (setq tag-to-org-alist (cons (cons (caar tmp) i) tag-to-org-alist)
  19             i (1+ i)
  20             tmp (cdr tmp)))
  21     (setq tmp clauses
  22           i 0)
  23     (while tmp
  24       (setq trans (cddr (cdar tmp)))
  25       (while trans
  26         (setq j (cdr (assoc (cadr (car trans)) tag-to-org-alist)))
  27         (if (not (member j (aref org-graph i)))
  28             (aset org-graph i (cons j (aref org-graph i))))
  29         (setq trans (cdr trans)))
  30       (setq i (1+ i)
  31             tmp (cdr tmp)))
  32     ;;(error "%s" org-graph)
  33     (setq tmp (digraph-split-as-forest org-graph)
  34           forest (aref tmp 0)
  35           org-to-forest (aref tmp 1)
  36           forest-to-org (aref tmp 2))
  37     (setq clauses
  38           (mapcar
  39            (lambda (c)
  40              (let ((tag (car c))
  41                    (action (cadr c))
  42                    (fail (nth 2 c))
  43                    (trs (nthcdr 3 c)))
  44                (setq trs
  45                      (mapcar
  46                       (lambda (next)
  47                         (list
  48                          (apply
  49                           'natset-union
  50                           (mapcar
  51                            (lambda (tr) (if (equal (cadr tr) next) (car tr) (natset-empty)))
  52                            trs))
  53                          next))
  54                       (natset-enum (apply 'natset-single (mapcar 'cadr trs)))))
  55                (cons tag (cons action (cons fail trs)))))
  56            clauses))
  57     `(let ((,automata-state-var ,(cdr (assoc start-tag tag-to-org-alist))))
  58        ,@(automata-exp-seq
  59           (automata-gen-state
  60            in-var clauses
  61            org-len
  62            (list (cdr (assoc start-tag tag-to-org-alist)))
  63            tag-to-org-alist
  64            (aref org-to-forest (cdr (assoc start-tag tag-to-org-alist)))
  65            forest org-to-forest forest-to-org)))))
  66
  67 (defun automata-gen-state (in-var clauses
  68                                   org-len
  69                                   start-states
  70                                   tag-to-org-alist
  71                                   forest-state forest org-to-forest forest-to-org)
  72   (let* ((org-states (aref forest-to-org forest-state))
  73          (forest-states (digraph-descents forest forest-state))
  74          (branch-length (+ (length org-states) (length forest-states)))
  75          (branch-to-org
  76           (vconcat
  77            (mapcar 'list org-states)
  78            (mapcar (lambda (forest-state)
  79                      (aref forest-to-org forest-state))
  80                    forest-states)))
  81          (org-to-branch
  82           (let ((org-to-branch (make-vector org-len nil))
  83                 (i 0) tmp)
  84             (while (< i branch-length)
  85               (setq tmp (aref branch-to-org i))
  86               (while tmp
  87                 (aset org-to-branch (car tmp) i)
  88                 (setq tmp (cdr tmp)))
  89               (setq i (1+ i)))
  90             org-to-branch))
  91          (branch-to-forest
  92           (vconcat
  93            (make-list (length org-states) nil)
  94            forest-states))
  95          (branch-state-range
  96           (vconcat
  97            (mapcar 'natset-single org-states)
  98            (mapcar (lambda (forest-state)
  99                      (apply 'natset-single
 100                             (aref forest-to-org forest-state)))
 101                    forest-states)))
 102          (branch-descents
 103           (vconcat
 104            (mapcar (lambda (org-state)
 105                      (let* ((c (nth org-state clauses))
 106                             (trs (nthcdr 3 c)))
 107                        (apply 'natset-union
 108                               (mapcar (lambda (tr)
 109                                         (natset-single
 110                                          (cdr (assoc (cadr tr) tag-to-org-alist))))
 111                                       trs))))
 112                    org-states)
 113            (mapcar (lambda (forest-state) ())
 114                    forest-states)))
 115          (all-descents (apply 'natset-union (append branch-descents ())))
 116          (branch-ascents
 117           (let* ((branch-ascents (make-vector branch-length 0))
 118                  (i 0) j)
 119             (while (< i branch-length)
 120               (setq j 0)
 121               (while (< j branch-length)
 122                 (if (natset-has-intersection-p (aref branch-state-range i)
 123                                                (aref branch-descents j))
 124                     (aset branch-ascents i
 125                           (1+ (aref branch-ascents i))))
 126                 (setq j (1+ j)))
 127               (setq i (1+ i)))
 128             branch-ascents))
 129          (start-inline nil)
 130          (branch-inline
 131           (let* ((branch-inline (make-vector branch-length nil))
 132                  (start-ns (apply 'natset-single start-states))
 133                  (i 0))
 134             (while (< i branch-length)
 135               (if (natset-has-intersection-p (aref branch-state-range i) start-ns)
 136                   (if (and (= (length start-states) 1)
 137                            (= (aref branch-ascents i) 0))
 138                       (progn
 139                         (setq start-inline i)
 140                         (aset branch-inline i t))
 141                     nil)
 142                 (if (= (aref branch-ascents i) 1)
 143                     (aset branch-inline i t)))
 144               (setq i (1+ i)))
 145             branch-inline))
 146          (branch-gen nil)
 147          (_
 148           (setq branch-gen
 149                 (vconcat
 150                  (mapcar
 151                   (lambda (org-state)
 152                     (cons
 153                      (lambda (org-state)
 154                        `(,(natset-single org-state)
 155                          nil ; don't duplicate.
 156                          ,@(let* ((c (nth org-state clauses)))
 157                              (automata-exp-seq
 158                               (nth 1 c) ; action
 159                               (if (null (nthcdr 3 c))
 160                                   (nth 2 c)
 161                                 `(automata-branch
 162                                   ,in-var ; input variable
 163                                   ,(natset-full) ; input is unpredictable.
 164                                   ,(nth 2 c) ; fail action
 165                                   ,@(let ((trs (nthcdr 3 c)))
 166                                       (mapcar
 167                                        (lambda (next-branch)
 168                                          (let ((input-range
 169                                                 (apply 'natset-union
 170                                                        (mapcar
 171                                                         (lambda (tr)
 172                                                           (if (member (cdr (assoc (cadr tr) tag-to-org-alist))
 173                                                                       (aref branch-to-org next-branch))
 174                                                               (car tr)
 175                                                             (natset-empty)))
 176                                                         trs))))
 177                                            `(,input-range ; input range
 178                                              ,(not (aref branch-inline next-branch)) ; duplicatable unless inlining.
 179                                              ,(let ((goto-list (apply
 180                                                                 'append
 181                                                                 (mapcar
 182                                                                  (lambda (tr)
 183                                                                    (let ((range (natset-intersection (car tr) input-range)))
 184                                                                      (if range
 185                                                                          `((,range
 186                                                                             t
 187                                                                             (automata-goto
 188                                                                              ,automata-state-var
 189                                                                              ,org-state
 190                                                                              ,(cdr (assoc (cadr tr) tag-to-org-alist)))))
 191                                                                        ())))
 192                                                                  trs))))
 193                                                 (if (= (length goto-list) 1)
 194                                                     (car (cddr (car goto-list)))
 195                                                   `(automata-branch
 196                                                     ,in-var
 197                                                     ,input-range
 198                                                     ,automata-never-fail
 199                                                     ,@goto-list)))
 200                                              ,@(if (aref branch-inline next-branch)
 201                                                    (automata-exp-seq
 202                                                     `(progn ,@(cddr (funcall (car (aref branch-gen next-branch))
 203                                                                              (cdr (aref branch-gen next-branch))))))
 204                                                  ()))))
 205                                        (natset-enum
 206                                         (apply 'natset-union
 207                                                (mapcar
 208                                                 (lambda (tr)
 209                                                   (natset-single
 210                                                    (aref org-to-branch
 211                                                          (cdr (assoc (cadr tr) tag-to-org-alist)))))
 212                                                 trs))))
 213                                       )))))))
 214                      org-state))
 215                   org-states)
 216                  (mapcar
 217                   (lambda (forest-state)
 218                     (cons
 219                      (lambda (forest-state)
 220                        `(,(natset-intersection
 221                            (apply 'natset-single (aref forest-to-org forest-state))
 222                            all-descents) ; state range
 223                          nil ; don't duplicate.
 224                          ,@(automata-exp-seq
 225                             (automata-gen-state
 226                              in-var clauses
 227                              org-len
 228                              (aref forest-to-org forest-state)
 229                              tag-to-org-alist
 230                              forest-state forest org-to-forest forest-to-org))))
 231                      forest-state))
 232                   forest-states))))
 233          (branches
 234           (let* ((branches ())
 235                  (i branch-length))
 236             (while (< 0 i)
 237               (setq i (1- i))
 238               (if (not (aref branch-inline i))
 239                   (setq branches
 240                         (cons
 241                          (funcall (car (aref branch-gen i))
 242                                   (cdr (aref branch-gen i)))
 243                          branches))))
 244             branches))
 245          )
 246     ;;(error "err")
 247     (if start-inline
 248         (apply
 249          'automata-seq-exp
 250          `(progn ,@(cddr (funcall (car (aref branch-gen start-inline))
 251                                   (cdr (aref branch-gen start-inline)))))
 252          (cond
 253           ((null branches) ())
 254           ((null (cdr branches))
 255            (cddr (car branches)))
 256           (t
 257            `((while t
 258                (automata-branch
 259                 ,automata-state-var ,(natset-full) ,automata-never-fail
 260                 ,@branches))))))
 261       (if (= (length branches) 1)
 262           `(while t ,@(cddr (car branches)))
 263         `(while t ; ,branch-inline ,branch-state-range ,branch-descents ,branch-ascents
 264                 (automata-branch
 265                  ,automata-state-var ,(natset-full) ,automata-never-fail
 266                  ,@branches))))))
 267
 268 (defun automata-seq-exp (&rest seq)
 269   (cond
 270    ((null seq) nil)
 271    ((null (cdr seq))
 272     (car seq))
 273    (t
 274     (setq seq
 275           (apply
 276            'append
 277            (mapcar
 278             (lambda (exp) (if (and (consp exp) (eq (car exp) 'progn))
 279                               (cdr exp)
 280                             (list exp)))
 281             seq)))
 282     (let ((rseq (reverse seq)))
 283       (cons 'progn
 284             (apply
 285              'append
 286              (apply
 287               'append
 288               (mapcar
 289                (lambda (exp) (if (null exp) () (list exp)))
 290                (nreverse (cdr rseq))))
 291              (list (list (car rseq)))))))))
 292
 293 (defun automata-exp-seq (&rest seq)
 294   (let ((exp (apply 'automata-seq-exp seq)))
 295     (if (and (consp exp) (eq (car exp) 'progn))
 296         (cdr exp)
 297       (list exp))))
 298
 299 (defmacro automata-goto (var curr next)
 300   (if (eq curr next)
 301       nil
 302     `(setq ,var ,next)))
 303
 304 (defmacro automata-branch (var range fail &rest clauses)
 305   (when (eq fail automata-never-fail)
 306     (setq range (natset-intersection
 307                  (apply 'natset-union (mapcar 'car clauses))
 308                  range)))
 309   (let ((len (length clauses))
 310         ns-list dup-list body-list tmp ns)
 311     (setq tmp clauses
 312           ns (natset-negate range))
 313     (while tmp
 314       (setq ns-list (cons (natset-sub (caar tmp) ns) ns-list)
 315             dup-list (cons (cadr (car tmp)) dup-list)
 316             body-list (cons (cddr (car tmp)) body-list)
 317             ns (natset-union ns (caar tmp))
 318             tmp (cdr tmp))
 319       (if (natset-empty-p (car ns-list))
 320           (setq ns-list (cdr ns-list)
 321                 dup-list (cdr dup-list)
 322                 body-list (cdr body-list))))
 323     (setq ns-list (nreverse ns-list)
 324           dup-list (nreverse dup-list)
 325           body-list (nreverse body-list))
 326     (automata-branch-i var range fail ns-list dup-list body-list)))
 327
 328 (defun automata-branch-i (var range fail ns-list dup-list body-list)
 329   (cond
 330    ((null ns-list) fail)
 331    ((null (cdr ns-list))
 332     (if (natset-include-p (car ns-list) range)
 333         (apply 'automata-seq-exp (car body-list))
 334       `(if ,(natset-gen-pred-exp (car ns-list) var range)
 335            ,(apply 'automata-seq-exp (car body-list))
 336          ,fail)))
 337    (t
 338     (let (tmp tmpn tmpd cut)
 339       (setq tmpn ns-list
 340             cut (natset-empty))
 341       (while tmpn
 342         (setq cut (natset-union cut (natset-boundary-set (car tmpn)))
 343               tmpn (cdr tmpn)))
 344       (setq tmpn ns-list
 345             tmpd dup-list)
 346       (while tmpn
 347         (if (not (car tmpd))
 348             (setq tmp (natset-minmax (car tmpn))
 349                   tmp (natset-sub tmp (natset-start-set tmp))
 350                   cut (natset-sub cut tmp)))
 351         (setq tmpn (cdr tmpn)
 352               tmpd (cdr tmpd)))
 353       (setq cut (natset-sub cut (natset-boundary-set (natset-minmax range))))
 354       (if (null (setq cut (natset-enum cut)))
 355           `(if ,(natset-gen-pred-exp (car ns-list) var range)
 356                ,(apply 'automata-seq-exp (car body-list))
 357              ,(automata-branch-i var
 358                                  (natset-sub range (car ns-list))
 359                                  fail
 360                                  (cdr ns-list)
 361                                  (cdr dup-list)
 362                                  (cdr body-list)))
 363         (let* ((mid (nth (/ (length cut) 2) cut))
 364                (lower (natset-seg 0 (1- mid)))
 365                (higher (natset-seg mid))
 366                ns-list1 dup-list1 body-list1
 367                ns-list2 dup-list2 body-list2
 368                )
 369           (while ns-list
 370             (if (natset-has-intersection-p lower (car ns-list))
 371                 (setq ns-list1 (cons (natset-intersection (car ns-list) lower) ns-list1)
 372                       dup-list1 (cons (car dup-list) dup-list1)
 373                       body-list1 (cons (car body-list) body-list1)))
 374             (if (natset-has-intersection-p higher (car ns-list))
 375                 (setq ns-list2 (cons (natset-intersection (car ns-list) higher) ns-list2)
 376                       dup-list2 (cons (car dup-list) dup-list2)
 377                       body-list2 (cons (car body-list) body-list2)))
 378             (setq ns-list (cdr ns-list)
 379                   dup-list (cdr dup-list)
 380                   body-list (cdr body-list)))
 381           ;;(if (or (null ns-list1) (null ns-list2)) (error "divide fail"))
 382           `(if (< ,var ,mid)
 383                ,(automata-branch-i var
 384                                    (natset-intersection range lower)
 385                                    fail ns-list1 dup-list1 body-list1)
 386              ,(automata-branch-i var
 387                                  (natset-intersection range higher)
 388                                  fail ns-list2 dup-list2 body-list2))))))))
 389
 390
 391 '(
 392 (npp (macroexpand '
 393 (automata pc 0
 394                 (1
 395                  (progn
 396                    (lex-match 1)
 397                    (lex-scan-unibyte-save))
 398                  (lex-fail))
 399                 (5
 400                  (progn
 401                    (lex-match 2)
 402                    (lex-scan-unibyte-save))
 403                  (lex-fail))
 404                 (4
 405                  (progn
 406                    (lex-scan-unibyte-read pc))
 407                  (lex-fail)
 408                  ((9 10) 5) ((32 33) 5))
 409                 (2
 410                  (progn
 411                    (lex-match 3)
 412                    (lex-scan-unibyte-save)
 413                    (lex-scan-unibyte-read pc))
 414                  (lex-fail)
 415                  ((13 14) 2)
 416                  ((0 9) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
 417                  ((10 11) 4))
 418                 (3
 419                  (progn
 420                    (lex-match 3)
 421                    (lex-scan-unibyte-save)
 422                    (lex-scan-unibyte-read pc))
 423                  (lex-fail)
 424                  ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
 425                  ((13 14) 2)
 426                  )
 427                 (0
 428                  (progn
 429                    (lex-match 3)
 430                    (lex-scan-unibyte-save)
 431                    (lex-scan-unibyte-read pc))
 432                  (lex-fail)
 433                  ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
 434                  ((13 14) 2)
 435                  ((9 10) 1) ((32 33) 1)))))
 436
 437 (npp (macroexpand '
 438 (automata pc 0
 439                 (0
 440                  (progn
 441                    (lex-match 3)
 442                    (lex-scan-unibyte-save)
 443                    (lex-scan-unibyte-read pc))
 444                  (lex-fail)
 445                  ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
 446                  ((13 14) 2)
 447                  ((9 10) 1) ((32 33) 1))
 448                 (1
 449                  (progn
 450                    (lex-match 1)
 451                    (lex-scan-unibyte-save))
 452                  (lex-fail))
 453                 (2
 454                  (progn
 455                    (lex-match 3)
 456                    (lex-scan-unibyte-save)
 457                    (lex-scan-unibyte-read pc))
 458                  (lex-fail)
 459                  ((13 14) 2)
 460                  ((0 9) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
 461                  ((10 11) 4))
 462                 (3
 463                  (progn
 464                    (lex-match 3)
 465                    (lex-scan-unibyte-save)
 466                    (lex-scan-unibyte-read pc))
 467                  (lex-fail)
 468                  ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
 469                  ((13 14) 2)
 470                  )
 471                 (4
 472                  (progn
 473                    (lex-scan-unibyte-read pc))
 474                  (lex-fail)
 475                  ((9 10) 5) ((32 33) 5))
 476                 (5
 477                  (progn
 478                    (lex-match 2)
 479                    (lex-scan-unibyte-save))
 480                  (lex-fail))
 481 )))
 482
 483 (npp
 484 (automata-gen-state
 485 'pc
 486 '((0 (progn (lex-match 3) (lex-scan-unibyte-save) (lex-scan-unibyte-read pc)) (lex-fail) ((9 10 32 33) 1) ((13 14) 2) ((0 9 10 13 14 32 33) 3))
 487   (1 (progn (lex-match 1) (lex-scan-unibyte-save)) (lex-fail))
 488   (2 (progn (lex-match 3) (lex-scan-unibyte-save) (lex-scan-unibyte-read pc)) (lex-fail) ((13 14) 2) ((0 9 11 13 14 32 33) 3) ((10 11) 4))
 489   (3 (progn (lex-match 3) (lex-scan-unibyte-save) (lex-scan-unibyte-read pc)) (lex-fail) ((13 14) 2) ((0 9 10 13 14 32 33) 3))
 490   (4 (progn (lex-scan-unibyte-read pc)) (lex-fail) ((9 10 32 33) 5))
 491   (5 (progn (lex-match 2) (lex-scan-unibyte-save)) (lex-fail)))
 492 6
 493 '(0)
 494 '((5 . 5) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (0 . 0))
 495 0
 496 [(4 1) (2) (3) nil nil]
 497 [0 4 1 1 2 3]
 498 [(0) (3 2) (4) (5) (1)]))
 499 )