fogus/select-match.lisp

## select-match.lisp
;;
;;  SELECT-MATCH macro (and IN macro)
;;
;; Copyright 1990   Stephen Adams
;;
;; You are free to copy, distribute and make derivative works of this
;; source provided that this copyright notice is displayed near the
;; beginning of the file.  No liability is accepted for the
;; correctness or performance of the code.  If you modify the code
;; please indicate this fact both at the place of modification and in
;; this copyright message.
;;
;;   Stephen Adams
;;   Department of Electronics and Computer Science
;;   University of Southampton
;;   SO9 5NH, UK
;;
;; sra@ecs.soton.ac.uk
;;

;;
;;  Synopsis:
;;
;;  (select-match expression
;;      (pattern  action+)*
;;  )
;;
;;      --- or ---
;;
;;  (select-match expression
;;      pattern => expression
;;      pattern => expression
;;      ...
;;  )
;;
;;  pattern ->  constant		;egs  1, #\x, #c(1.0 1.1)
;;          |   symbol                  ;matches anything
;;          |   'anything               ;must be EQUAL
;;          |   (pattern = pattern)     ;both patterns must match
;;          |   (#'function pattern)    ;predicate test
;;          |   (pattern . pattern)	;cons cell
;;

;;  Example
;;
;;  (select-match item
;;      (('if e1 e2 e3) 'if-then-else)				;(1)
;;      ((#'oddp k)     'an-odd-integer)			;(2)
;;      (((#'treep tree) = (hd . tl))   'something-else)	;(3)
;;      (other          'anything-else))			;(4)
;;
;;  Notes
;;
;;  .   Each pattern is tested in turn.  The first match is taken.
;;
;;  .   If no pattern matches, an error is signalled.
;;
;;  .   Constant patterns (things X for which (CONSTANTP X) is true, i.e.
;;      numbers, strings, characters, etc.) match things which are EQUAL.
;;
;;  .   Quoted patterns (which are CONSTANTP) are constants.
;;
;;  .   Symbols match anything. The symbol is bound to the matched item
;;      for the execution of the actions.
;;      For example, (SELECT-MATCH '(1 2 3)
;;                      (1 . X) => X
;;                   )
;;      returns (2 3) because X is bound to the cdr of the candidate.
;;
;;  .   The two pattern match (p1 = p2) can be used to name parts
;;      of the matched structure.  For example, (ALL = (HD . TL))
;;      matches a cons cell. ALL is bound to the cons cell, HD to its car
;;      and TL to its tail.
;;
;;  .   A predicate test applies the predicate to the item being matched.
;;      If the predicate returns NIL then the match fails.
;;      If it returns truth, then the nested pattern is matched.  This is
;;      often just a symbol like K in the example.
;;
;;  .   Care should be taken with the domain values for predicate matches.
;;      If, in the above eg, item is not an integer, an error would occur
;;      during the test.  A safer pattern would be
;;          (#'integerp (#'oddp k))
;;      This would only test for oddness of the item was an integer.
;;
;;  .   A single symbol will match anything so it can be used as a default
;;      case, like OTHER above.
;;


(eval-when (compile) (proclaim '(optimize (safety 2))))

(defmacro select-match (expression &rest patterns)
    (let* ( (do-let (not (atom expression)))
            (key    (if do-let (gensym) expression))
            (cbody  (expand-select-patterns key patterns))
            (cform  `(cond . ,cbody))
          )

        (if do-let
            `(let ((,key ,expression)) ,cform)
            cform))
)


(defun expand-select-patterns (key patterns)
    (if (eq (second patterns) '=>)
        (expand-select-patterns-style-2 key patterns)
        (expand-select-patterns-style-1 key patterns)))


(defun expand-select-patterns-style-1 (key patterns)

  (if (null patterns)

    `((T (error "Case select pattern match failure on ~S" ,key)))

    (let ((pattern  (caar patterns))
          (actions  (cdar patterns))
          (rest     (cdr patterns)) )

        (let  ( (test       (compile-select-test key pattern))
                (bindings   (compile-select-bindings key pattern actions)))

            `(  ,(if bindings  `(,test (let ,bindings . ,actions))
                               `(,test . ,actions))
              . ,(if (eq test t)
                    nil
                    (expand-select-patterns-style-1 key rest)))
        )
    )
))


(defun expand-select-patterns-style-2 (key patterns)

  (if (null patterns)

    `((T (error "Case select pattern match failure on ~S" ,key)))

    (let ((pattern  (first patterns))
          (arrow    (if (or (< (length patterns) 3)
                            (not (eq (second patterns) '=>)))
                        (error "Illegal patterns: ~S" patterns)))
          (actions  (list (third patterns)))
          (rest     (cdddr patterns)) )

        (let  ( (test       (compile-select-test key pattern))
                (bindings   (compile-select-bindings key pattern actions)))

            `(  ,(if bindings  `(,test (let ,bindings . ,actions))
                               `(,test . ,actions))
              . ,(if (eq test t)
                    nil
                    (expand-select-patterns-style-2 key rest)))
        )
    )
))


(defun compile-select-test (key pattern)
    (let  ((tests (remove-if
                        #'(lambda (item) (eq item t))
                        (compile-select-tests key pattern))))
        (cond
            ;; note AND does this anyway, but this allows us to tell if
            ;; the pattern will always match.
            ((null tests)           t)
            ((= (length tests) 1)   (car tests))
            (T                      `(and . ,tests)))))


(defun compile-select-tests (key pattern)

    (cond   ((constantp pattern)   `((,(cond ((numberp pattern) 'eql)
                                             ((symbolp pattern) 'eq)
                                             (T                'equal))
                                       ,key ,pattern)))

            ((symbolp pattern)      '(T))

            ((select-double-match? pattern)
                        (append
                            (compile-select-tests key (first pattern))
                            (compile-select-tests key (third pattern))))

            ((select-predicate? pattern)
                        (append
                            `((,(second (first pattern)) ,key))
                            (compile-select-tests key (second pattern))))

            ((consp pattern)
                        (append
                            `((consp ,key))
                            (compile-select-tests (!cs-car key) (car
pattern))
                            (compile-select-tests (!cs-cdr key) (cdr
pattern))))

            ('T         (error "Illegal select pattern: ~S" pattern))
    )
)


(defun compile-select-bindings (key pattern action)

    (cond   ((constantp pattern)    '())
            ((symbolp pattern)
                (if (select!-in-tree pattern action) `((,pattern ,key))
                                                     '()))

            ((select-double-match? pattern)
                    (append
                    	(compile-select-bindings key (first pattern) action)
                        (compile-select-bindings key (third pattern)
action)))

            ((select-predicate? pattern)
                        (compile-select-bindings key (second pattern)
action))

            ((consp pattern)
              (append
                (compile-select-bindings (!cs-car key) (car pattern)
action)
                (compile-select-bindings (!cs-cdr key) (cdr pattern)
action)))
    )
)


(defun select!-in-tree (atom tree)
    (or (eq atom tree)
        (if (consp tree)
            (or (select!-in-tree atom (car tree))
                (select!-in-tree atom (cdr tree))))))

(defun select-double-match? (pattern)
    ;;  (<pattern> = <pattern>)
    (and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
         (null (cdddr pattern))
         (eq (second pattern) '=)))


(defun select-predicate? (pattern)
    ;; ((function <f>) <pattern>)
    (and    (consp pattern)
            (consp (cdr pattern))
            (null (cddr pattern))
            (consp (first pattern))
            (consp (cdr (first pattern)))
            (null (cddr (first pattern)))
            (eq (caar pattern) 'function)))


(defun !cs-car (exp)
    (!cs-car/cdr 'car exp '(
            (car . caar)    (cdr . cadr)    (caar . caaar)  (cadr . caadr)
            (cdar . cadar)  (cddr . caddr)
            (caaar . caaaar)    (caadr . caaadr)    (cadar . caadar)
            (caddr . caaddr)    (cdaar . cadaar)    (cdadr . cadadr)
            (cddar . caddar)    (cdddr . cadddr))))

(defun !cs-cdr (exp)
    (!cs-car/cdr 'cdr exp '(
            (car . cdar)    (cdr . cddr)    (caar . cdaar)  (cadr . cdadr)
            (cdar . cddar)  (cddr . cdddr)
            (caaar . cdaaar)    (caadr . cdaadr)    (cadar . cdadar)
            (caddr . cdaddr)    (cdaar . cddaar)    (cdadr . cddadr)
            (cddar . cdddar)    (cdddr . cddddr))))

(defun !cs-car/cdr (op exp table)
    (if (and (consp exp) (= (length exp) 2))
        (let ((replacement  (assoc (car exp) table)))
            (if replacement
                `(,(cdr replacement) ,(second exp))
                `(,op ,exp)))
        `(,op ,exp)))

;(setf c1 '(select-match x (a 1) (b 2 3 4)))
;(setf c2 '(select-match (car y)
;            (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
else))))
;(setf c3 '(select-match (caddr y)
;            ((all = (x y)) (list x y all))
;            ((a '= b)      (list 'assign a b))
;            ((#'oddp k)     (1+ k)))))


;;
;;  IN macro
;;
;;  (IN exp LET pat1 = exp1
;;              pat2 = exp2
;;              ...)
;;
;;  (IN exp LET* pat1 = exp1
;;               pat2 = exp2
;;               ...)
;;


(defmacro in (&rest form)
    (select-match form
        (exp 'let . pats)   =>
            (let* ( (exps   (select-in-let-parts pats 'exp))
                    (pats   (select-in-let-parts pats 'pat))
                    (vars   (mapcar #'(lambda (x) (gensym)) exps))

                  )
                `(let ,(mapcar #'list vars exps)
                    ,(reduce
                        #'(lambda (var-pat subselection)
                            (let ((var  (first var-pat))
                                  (pat  (second var-pat)))
                                `(select-match ,var
                                    ,pat => ,subselection
                                    else => (error "IN-LET type error: ~S
doesnt match ~S" ,var ',pat))))

                        (mapcar #'list vars pats)
                        :from-end t
                        :initial-value exp)))

        (exp 'let*)         => exp

        (exp 'let* pat '= patexp . pats)  =>
            (let ((var (gensym)))
                `(let ((,var ,patexp))
                    (select-match ,var
                        ,pat => (in ,exp let* . ,pats)
                        else => (error "IN-LET type error: ~S doesnt match
~S" ,var ',pat))))

        else                =>
            (error "Illegal IN form ~S" form)))


(defun select-in-let-parts (pats part)
    (select-match pats
        nil =>
            nil
        (pat '= exp . rest) =>
            (cons (select-match part
                    'exp => exp
                    'pat => pat)
                  (select-in-let-parts rest part))
        other =>
            (error "Illegal LET form(s): ~S" pats)))

;(setf eg1 '(in (list h1 h2 t1 t2)
;            let
;                (h1 . t1) = (foo x)
;                (h2 . t2) = (bar y))))
	;;
	;; SELECT-MATCH macro (and IN macro)
	;;
	;; Copyright 1990 Stephen Adams
	;;
	;; You are free to copy, distribute and make derivative works of this
	;; source provided that this copyright notice is displayed near the
	;; beginning of the file. No liability is accepted for the
	;; correctness or performance of the code. If you modify the code
	;; please indicate this fact both at the place of modification and in
	;; this copyright message.
	;;
	;; Stephen Adams
	;; Department of Electronics and Computer Science
	;; University of Southampton
	;; SO9 5NH, UK
	;;
	;; sra@ecs.soton.ac.uk
	;;

	;;
	;; Synopsis:
	;;
	;; (select-match expression
	;; (pattern action+)*
	;; )
	;;
	;; --- or ---
	;;
	;; (select-match expression
	;; pattern => expression
	;; pattern => expression
	;; ...
	;; )
	;;
	;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
	;; \| symbol ;matches anything
	;; \| 'anything ;must be EQUAL
	;; \| (pattern = pattern) ;both patterns must match
	;; \| (#'function pattern) ;predicate test
	;; \| (pattern . pattern) ;cons cell
	;;

	;; Example
	;;
	;; (select-match item
	;; (('if e1 e2 e3) 'if-then-else) ;(1)
	;; ((#'oddp k) 'an-odd-integer) ;(2)
	;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
	;; (other 'anything-else)) ;(4)
	;;
	;; Notes
	;;
	;; . Each pattern is tested in turn. The first match is taken.
	;;
	;; . If no pattern matches, an error is signalled.
	;;
	;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
	;; numbers, strings, characters, etc.) match things which are EQUAL.
	;;
	;; . Quoted patterns (which are CONSTANTP) are constants.
	;;
	;; . Symbols match anything. The symbol is bound to the matched item
	;; for the execution of the actions.
	;; For example, (SELECT-MATCH '(1 2 3)
	;; (1 . X) => X
	;; )
	;; returns (2 3) because X is bound to the cdr of the candidate.
	;;
	;; . The two pattern match (p1 = p2) can be used to name parts
	;; of the matched structure. For example, (ALL = (HD . TL))
	;; matches a cons cell. ALL is bound to the cons cell, HD to its car
	;; and TL to its tail.
	;;
	;; . A predicate test applies the predicate to the item being matched.
	;; If the predicate returns NIL then the match fails.
	;; If it returns truth, then the nested pattern is matched. This is
	;; often just a symbol like K in the example.
	;;
	;; . Care should be taken with the domain values for predicate matches.
	;; If, in the above eg, item is not an integer, an error would occur
	;; during the test. A safer pattern would be
	;; (#'integerp (#'oddp k))
	;; This would only test for oddness of the item was an integer.
	;;
	;; . A single symbol will match anything so it can be used as a default
	;; case, like OTHER above.
	;;


	(eval-when (compile) (proclaim '(optimize (safety 2))))

	(defmacro select-match (expression &rest patterns)
	(let* ( (do-let (not (atom expression)))
	(key (if do-let (gensym) expression))
	(cbody (expand-select-patterns key patterns))
	(cform `(cond . ,cbody))
	)

	(if do-let
	`(let ((,key ,expression)) ,cform)
	cform))
	)


	(defun expand-select-patterns (key patterns)
	(if (eq (second patterns) '=>)
	(expand-select-patterns-style-2 key patterns)
	(expand-select-patterns-style-1 key patterns)))


	(defun expand-select-patterns-style-1 (key patterns)

	(if (null patterns)

	`((T (error "Case select pattern match failure on ~S" ,key)))

	(let ((pattern (caar patterns))
	(actions (cdar patterns))
	(rest (cdr patterns)) )

	(let ( (test (compile-select-test key pattern))
	(bindings (compile-select-bindings key pattern actions)))

	`( ,(if bindings `(,test (let ,bindings . ,actions))
	`(,test . ,actions))
	. ,(if (eq test t)
	nil
	(expand-select-patterns-style-1 key rest)))
	)
	)
	))



	(defun expand-select-patterns-style-2 (key patterns)

	(if (null patterns)

	`((T (error "Case select pattern match failure on ~S" ,key)))

	(let ((pattern (first patterns))
	(arrow (if (or (< (length patterns) 3)
	(not (eq (second patterns) '=>)))
	(error "Illegal patterns: ~S" patterns)))
	(actions (list (third patterns)))
	(rest (cdddr patterns)) )

	(let ( (test (compile-select-test key pattern))
	(bindings (compile-select-bindings key pattern actions)))

	`( ,(if bindings `(,test (let ,bindings . ,actions))
	`(,test . ,actions))
	. ,(if (eq test t)
	nil
	(expand-select-patterns-style-2 key rest)))
	)
	)
	))



	(defun compile-select-test (key pattern)
	(let ((tests (remove-if
	#'(lambda (item) (eq item t))
	(compile-select-tests key pattern))))
	(cond
	;; note AND does this anyway, but this allows us to tell if
	;; the pattern will always match.
	((null tests) t)
	((= (length tests) 1) (car tests))
	(T `(and . ,tests)))))


	(defun compile-select-tests (key pattern)

	(cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
	((symbolp pattern) 'eq)
	(T 'equal))
	,key ,pattern)))

	((symbolp pattern) '(T))

	((select-double-match? pattern)
	(append
	(compile-select-tests key (first pattern))
	(compile-select-tests key (third pattern))))

	((select-predicate? pattern)
	(append
	`((,(second (first pattern)) ,key))
	(compile-select-tests key (second pattern))))

	((consp pattern)
	(append
	`((consp ,key))
	(compile-select-tests (!cs-car key) (car
	pattern))
	(compile-select-tests (!cs-cdr key) (cdr
	pattern))))

	('T (error "Illegal select pattern: ~S" pattern))
	)
	)


	(defun compile-select-bindings (key pattern action)

	(cond ((constantp pattern) '())
	((symbolp pattern)
	(if (select!-in-tree pattern action) `((,pattern ,key))
	'()))

	((select-double-match? pattern)
	(append
	(compile-select-bindings key (first pattern) action)
	(compile-select-bindings key (third pattern)
	action)))

	((select-predicate? pattern)
	(compile-select-bindings key (second pattern)
	action))

	((consp pattern)
	(append
	(compile-select-bindings (!cs-car key) (car pattern)
	action)
	(compile-select-bindings (!cs-cdr key) (cdr pattern)
	action)))
	)
	)


	(defun select!-in-tree (atom tree)
	(or (eq atom tree)
	(if (consp tree)
	(or (select!-in-tree atom (car tree))
	(select!-in-tree atom (cdr tree))))))

	(defun select-double-match? (pattern)
	;; (<pattern> = <pattern>)
	(and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
	(null (cdddr pattern))
	(eq (second pattern) '=)))


	(defun select-predicate? (pattern)
	;; ((function <f>) <pattern>)
	(and (consp pattern)
	(consp (cdr pattern))
	(null (cddr pattern))
	(consp (first pattern))
	(consp (cdr (first pattern)))
	(null (cddr (first pattern)))
	(eq (caar pattern) 'function)))




	(defun !cs-car (exp)
	(!cs-car/cdr 'car exp '(
	(car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
	(cdar . cadar) (cddr . caddr)
	(caaar . caaaar) (caadr . caaadr) (cadar . caadar)
	(caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
	(cddar . caddar) (cdddr . cadddr))))

	(defun !cs-cdr (exp)
	(!cs-car/cdr 'cdr exp '(
	(car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
	(cdar . cddar) (cddr . cdddr)
	(caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
	(caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
	(cddar . cdddar) (cdddr . cddddr))))

	(defun !cs-car/cdr (op exp table)
	(if (and (consp exp) (= (length exp) 2))
	(let ((replacement (assoc (car exp) table)))
	(if replacement
	`(,(cdr replacement) ,(second exp))
	`(,op ,exp)))
	`(,op ,exp)))

	;(setf c1 '(select-match x (a 1) (b 2 3 4)))
	;(setf c2 '(select-match (car y)
	; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
	else))))
	;(setf c3 '(select-match (caddr y)
	; ((all = (x y)) (list x y all))
	; ((a '= b) (list 'assign a b))
	; ((#'oddp k) (1+ k)))))



	;;
	;; IN macro
	;;
	;; (IN exp LET pat1 = exp1
	;; pat2 = exp2
	;; ...)
	;;
	;; (IN exp LET* pat1 = exp1
	;; pat2 = exp2
	;; ...)
	;;




	(defmacro in (&rest form)
	(select-match form
	(exp 'let . pats) =>
	(let* ( (exps (select-in-let-parts pats 'exp))
	(pats (select-in-let-parts pats 'pat))
	(vars (mapcar #'(lambda (x) (gensym)) exps))

	)
	`(let ,(mapcar #'list vars exps)
	,(reduce
	#'(lambda (var-pat subselection)
	(let ((var (first var-pat))
	(pat (second var-pat)))
	`(select-match ,var
	,pat => ,subselection
	else => (error "IN-LET type error: ~S
	doesnt match ~S" ,var ',pat))))

	(mapcar #'list vars pats)
	:from-end t
	:initial-value exp)))

	(exp 'let*) => exp

	(exp 'let* pat '= patexp . pats) =>
	(let ((var (gensym)))
	`(let ((,var ,patexp))
	(select-match ,var
	,pat => (in ,exp let* . ,pats)
	else => (error "IN-LET type error: ~S doesnt match
	~S" ,var ',pat))))

	else =>
	(error "Illegal IN form ~S" form)))




	(defun select-in-let-parts (pats part)
	(select-match pats
	nil =>
	nil
	(pat '= exp . rest) =>
	(cons (select-match part
	'exp => exp
	'pat => pat)
	(select-in-let-parts rest part))
	other =>
	(error "Illegal LET form(s): ~S" pats)))

	;(setf eg1 '(in (list h1 h2 t1 t2)
	; let
	; (h1 . t1) = (foo x)
	; (h2 . t2) = (bar y))))