matchex.lsp

; this script requires onnewlisp.lsp
; onnewlisp.lsp requires newlisp-utility.lsp
; onnewlisp.lsp has (include "newlisp-utility.lsp")
; include is defined at init.lsp
(include "onnewlisp.lsp")

(define-macro (aif2)
; (aif2 test &optional then else)
  (letex (_win (gensym)
          _test (args 0)
          _then (second (args))
          _else (third (args)))
    (multiple-value-bind (it _win) _test
      (if (or it _win) _then _else))))

(define-macro (acond2)
; (acond2 &rest clauses)
  (if (null? (args))
      nil
    (letex (_cl1st  (args 0 0)
            _clrest (cons 'begin (1 (args 0)))
            _acondrest (cons 'acond2 (1 (args))) 
            _val (gensym)
            _win (gensym))
      (multiple-value-bind (_val _win) _cl1st
        (if (or _val _win)
            (let (it _val) _clrest)
              _acondrest)))))

(define-macro (matchEx)
  (letex (_exec (cons 'matchx (args))
          _flag (eval values:mv-set))
    (let (_res _exec)
      (if _flag _res (_res 0)))))

(defun matchx (x y (binds '()))
  (acond2
    ((or (= x y) (= x '_) (= y '_)) (list binds t))
    ((binding x binds) (matchx it y binds))
    ((binding y binds) (matchx x it binds))
    ((var? x) (list  (cons (cons x y) binds) t))
    ((var? y) (list  (cons (cons y x) binds) t))
    ((and (consp x) (consp y) (matchx (first x) (first y) binds))
      (matchx (rest x) (rest y) it))
    (t (list nil nil))))

(defun var? (x)
  (and (symbol? x) (= ((string x) 0) "?")))

(defun binding (x binds)
  (if (atom? x)
      (labels ((recbind (x binds)
                 (aif (and binds (assoc x binds))
                      (or (recbind (rest it) binds)
                   it))))
        (let ((b (recbind x binds)))
          (list  (second (mklist b)) b)))
    (list nil nil)))

(defun destruc (pat seq)
  (labels ((add/c (x) (letex (_x x) ''_x))
           (destruc-ex (_pat _seq)
             (if (null _pat) '()
               (let (_rest (cond ((atom? _pat) _pat)
                                 ((= (_pat 0) '&rest) (_pat -1))
                                 (true nil)))
                 (if _rest (list _rest (add/c _seq))
                   (let (_pat1 (_pat 0)
                         _seq1 (_seq 0))
                     (when (array? _seq1) (setf _seq1 (array-list $it))) 
                     (if (list? _pat1)
                           (append (destruc-ex _pat1 _seq1) (destruc-ex (rest _pat) (rest _seq)))
                         (and (null (rest _pat)) (string? _seq))
                           (list _pat1 _seq)
               (append (list _pat1 (add/c _seq1)) (destruc-ex (rest _pat) (rest _seq))))))))))
    (destruc-ex pat seq)))

(defun match1 (lst)
  (let (res '())
    (dolist (x lst)
      (if (var? (x 0)) (let (pos (ref (x 0) res)
                             key (lookup (x 0) res))
                         (if pos 
                             (if (!= key (x 1)) (push nil res -1))
                           (push x res -1)))
          (= '_ (x 0)) nil 
          (!= (eval (x 0))  (eval (x 1))) (push nil res)))
    (if (find nil res) nil res)))