;;; case extension including pattern matching
;;;
;;;   The nomenclature of r7rs is (case key ((datum...) expression...)),
;;;     but I prefer "selector" to "key", "target" to "datum", and "body" to "expression".
;;;
;;;   any target not a list, vector, or pattern descriptor (see below) is matched with equivalent?
;;;   pattern descriptors are of the form #< whatever >
;;;
;;;     #<>           any expr matches
;;;     #<func>       expr matches if (func expr)
;;;     #<label:func> expr matches as above, expr is saved under "label"
;;;     #<label:>     any expr matches, and is saved under "label"
;;;     #<label>      expr must match value saved under "label"
;;;     #<...>        skip exprs covered by the ellipsis
;;;     #<label:...>  skip as above, save skipped exprs under "label" as a quoted list
;;;                   a pattern can have any number of labelled ellipses overall, but just one unnamed ellipsis, and only one ellipsis per pair or vector
;;;     #<label,func:...> labelled ellipsis which matches if (func expr) -- expr is the ellipsis list
;;;                   label is not optional in this case
;;;     #<"regexp">   pattern is a regular expression to be matched against a string
;;;     #<label:"regexp"> labelled string that matches regexp
;;;
;;;   lists and vectors are matched item by item, other sequences are matched directly via equivalent?
;;;   if a label occurs in the result body, the expression it labelled is substituted for it
;;;   the labels and case*'s matching function can be used anywhere -- see below, "match?" etc
;;;
;;;   (case* x ((3.14) 'pi)) returns 'pi if x is 3.14
;;;   (case* "asdf" (("asde") 0) (("asdf") 1) (else 2)) is 1
;;;   (case* "asdf" ((#<"asd*">) 0) (("asdf") 1) (else 2)) is 0
;;;   (case* x ((#<symbol?>))) returns #t if x is a symbol
;;;   (case* x (((+ 1 #<symbol?>)))) matches if x is any list of the form '(+ 1 x) or any other symbol in place of "x"
;;;   (case* x (((#<symbol?> #<e1:...> (+ #<e2:...>))) (append #<e1> #<e2>))), passed '(a b c d (+ 1 2)), returns '(b c d 1 2)

(provide 'case.scm)
(unless (provided? 'windows) 
  (require libc.scm))

(define case* 
  (let ((case*-labels (lambda (label)
			(let ((labels ((funclet ((funclet 'case*) 'case*-helper)) 'labels)))
			  (labels (symbol->string label))))) ; if ellipsis, this has been quoted by case*
	
	(case*-match? (lambda* (matchee pattern (e (curlet)))
			(let ((matcher ((funclet ((funclet 'case*) 'case*-helper)) 'handle-sequence)))
			  (or (equivalent? matchee pattern)
			      (and (or (pair? matchee) 
				       (vector? matchee))
				   (begin
				     (fill! ((funclet ((funclet 'case*) 'case*-helper)) 'labels) #f) ; clear labels
				     ((matcher pattern e) matchee)))))))
	(case*-helper
	 (with-let (unlet)
	   (define labels (make-hash-table))

	   (define (ellipsis? pat)
	     (and (undefined? pat)
		  (or (equal? pat #<...>)
		      (let ((str (object->string pat)))
			(and (char-position #\: str)
			     (string=? "...>" (substring str (- (length str) 4))))))))
	     
	   (define (ellipsis-pair-position pos pat)
	     (and (pair? pat)
		  (if (ellipsis? (car pat))
		      pos
		      (ellipsis-pair-position (+ pos 1) (cdr pat)))))

	   (define (ellipsis-vector-position pat vlen)
	     (let loop ((pos 0))
	       (and (< pos vlen)
		    (if (ellipsis? (pat pos))
			pos
			(loop (+ pos 1))))))

	   (define (splice-out-ellipsis sel pat pos e)
	     (let ((sel-len (length sel))
		   (new-pat-len (- (length pat) 1))
		   (ellipsis-label (and (not (eq? (pat pos) #<...>))              
					(let* ((str (object->string (pat pos)))
					       (colon (char-position #\: str)))
					  (and colon
					       (substring str 2 colon))))))
	       (let ((func (and (string? ellipsis-label)
				(let ((comma (char-position #\, ellipsis-label)))
				  (and comma
				       (let ((str (substring ellipsis-label (+ comma 1))))
					 (set! ellipsis-label (substring ellipsis-label 0 comma))
					 (let ((func-val (symbol->value (string->symbol str) e)))
					   (if (undefined? func-val)
					       (error 'unbound-variable "function ~S is undefined\n" func))
					   (if (not (procedure? func-val))
					       (error 'wrong-type-arg "~S is not a function\n" func))
					   func-val)))))))
		 (if (pair? pat)
		     (cond ((= pos 0)               ; ellipsis at start of pattern
			    (if ellipsis-label
				(set! (labels ellipsis-label) 
				      (list 'quote (copy sel (make-list (- sel-len new-pat-len))))))
			    (values (list-tail sel (- sel-len new-pat-len))
				    (cdr pat)
				    (or (not func)
					(func (cadr (labels ellipsis-label)))))) ; value is (quote ...) and we want the original list here
			   
			   ((= pos new-pat-len)     ; ellipsis at end of pattern
			    (if ellipsis-label
				(set! (labels ellipsis-label) 
				      (list 'quote (copy sel (make-list (- sel-len pos)) pos))))
			    (values (copy sel (make-list pos))
				    (copy pat (make-list pos))
				    (or (not func) 
					(func (cadr (labels ellipsis-label))))))
			   
			   (else                    ; ellipsis somewhere in the middle
			    (let ((new-pat (make-list new-pat-len))
				  (new-sel (make-list new-pat-len)))
			      (if ellipsis-label
				  (set! (labels ellipsis-label) 
					(list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos))))
			      (copy pat new-pat 0 pos)
			      (copy pat (list-tail new-pat pos) (+ pos 1))
			      (copy sel new-sel 0 pos)
			      (copy sel (list-tail new-sel pos) (- sel-len pos))
			      (values new-sel new-pat
				      (or (not func) 
					  (func (cadr (labels ellipsis-label))))))))
		     
		     (cond ((= pos 0)
			    (if ellipsis-label
				(set! (labels ellipsis-label) 
				      (list 'quote (copy sel (make-list (- sel-len new-pat-len))))))
			    (values (subvector sel (max 0 (- sel-len new-pat-len)) sel-len) ; was new-pat-len (max 0 (- sel-len new-pat-len))
				    (subvector pat 1 (+ new-pat-len 1))                     ;     new-pat-len 1
				    (or (not func) 
					(func (cadr (labels ellipsis-label))))))
			   
			   ((= pos new-pat-len)
			    (if ellipsis-label
				(set! (labels ellipsis-label) 
				      (list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos))))
			    (values (subvector sel 0 new-pat-len)
				    (subvector pat 0 new-pat-len)
				    (or (not func) 
					(func (cadr (labels ellipsis-label))))))
			   
			   (else
			    (let ((new-pat (make-vector new-pat-len))
				  (new-sel (make-vector new-pat-len)))
			      (if ellipsis-label
				  (set! (labels ellipsis-label) 
					(list 'quote (copy sel (make-list (- sel-len new-pat-len)) pos))))
			      (copy pat new-pat 0 pos)
			      (copy pat (subvector new-pat pos new-pat-len) (+ pos 1))       ; (- new-pat-len pos) pos)   copy: (+ pos 1))
			      (copy sel new-sel 0 pos)
			      (copy sel (subvector new-sel pos new-pat-len) (- sel-len pos))
			                                                                     ; (- new-pat-len pos) pos)  copy: (- sel-len pos))
			      (values new-sel new-pat
				      (or (not func) 
					  (cadr (func (labels ellipsis-label))))))))))))
	     
	   (define handle-regex
	     (let ((rg ((*libc* 'regex.make))) ; is this safe?
		   (local-regcomp (*libc* 'regcomp))
		   (local-regerror (*libc* 'regerror))
		   (local-regexec (*libc* 'regexec))
		   (local-regfree (*libc* 'regfree)))
	       (lambda (reg)
		 (lambda (x)
		   (and (string? x)
			(let ((res (local-regcomp rg (substring reg 1 (- (length reg) 1)) 0)))
			  (unless (zero? res)
			    (error 'regex-error "~S~%" (local-regerror res rg)))
			  (set! res (local-regexec rg x 0 0))
			  (local-regfree rg)
			  (zero? res)))))))

	   (define (undefined->function undef e)   ; handle the pattern descriptor ("undef") of the form #< whatever >, "e" = caller's curlet
	     (let* ((str1 (object->string undef))
		    (str1-end (- (length str1) 1)))
	       (if (not (char=? (str1 str1-end) #\>))
		   (error 'wrong-type-arg "pattern descriptor does not end in '>': ~S\n" str1))
	       (let ((str (substring str1 2 str1-end)))
		 (if (= (length str) 0)                                           ; #<> = accept anything
		     (lambda (x) #t)
		     (let ((colon (char-position #\: str)))
		       (cond (colon                                               ; #<label:...> might be #<label:> or #<label:func>
			      (let ((label (substring str 0 colon))               ; str is label:...
				    (func (substring str (+ colon 1))))           ; func might be ""
				(cond ((labels label)                             ; see if we already have saved something under this label
				       (lambda (sel)                              ;   if so, return function that will return an error
					 (error 'syntax-error "label ~S is defined twice: old: ~S, new: ~S~%" label (labels label) sel)))
				      
				      ;; otherwise the returned function needs to store the current sel-item under label in labels
				      ((zero? (length func))
				       (lambda (x)
					 (set! (labels label) x)                  ; #<label:>, set label, accept anything
					 #t))
				      
				      ((char=? (func 0) #\")                      ; labelled regex, #<label:"regexp">
				       (lambda (x)
					 (set! (labels label) x)
					 (handle-regex func)))
				      
				      (else                                       ; #<label:func>
				       (let ((func-val (symbol->value (string->symbol func) e)))
					 (if (undefined? func-val)
					     (error 'unbound-variable "function ~S is undefined\n" func)
					     (if (not (procedure? func-val))
						 (error 'wrong-type-arg "~S is not a function\n" func)
						 (lambda (x)                     ; set label and call func
						   (set! (labels label) x)
						   (func-val x)))))))))
			     
			     ;; if no colon either #<label> or #<func> or #<"regexp"> -- label means match its saved expr, func = call func
			     ((char=? (str 0) #\")
			      (handle-regex str))
			     
			     (else                                                ; #<label> or #<func>
			      (let ((saved (labels str)))
				(if saved                                         ; #<label>
				    (lambda (x) (equivalent? x saved))
				    (symbol->value (string->symbol str) e)))))))))) ; #<func> using curlet=e passed in above
	   
	   (define (handle-pattern sel-item pat-item e)
	     (and (undefined? pat-item)      ; turn #<func> into func and call it on the current selector element
		  (not (eq? pat-item #<undefined>))
		  (let ((func (undefined->function pat-item e)))
		    (if (undefined? func)
			(error 'unbound-variable "function ~S is undefined\n" pat-item))
		    (if (not (procedure? func))
			(error 'wrong-type-arg "~S is not a function\n" func))
		    (func sel-item))))

	   (define (handle-sequence pat e)
	     (lambda (sel)
	       ;(format *stderr* "~S ~S~%" sel pat)
	       (and (eq? (type-of sel) (type-of pat))
		    (let ((func-ok #t))

		      (when (or (pair? pat)                           ; look for ellipsis
				(vector? pat))
			(if (pair? (cyclic-sequences pat))
			    (error 'wrong-type-arg "case* pattern is cyclic: ~S~%" pat))
			(let ((pos (if (pair? pat)
				       (ellipsis-pair-position 0 pat)
				       (ellipsis-vector-position pat (length pat)))))
			  (when (and pos
				     (>= (length sel) (- (length pat) 1))) ; else pat without ellipsis is too long for sel
			    (let ((new-vars (list (splice-out-ellipsis sel pat pos e))))
			      (set! sel (car new-vars))
			      (set! pat (cadr new-vars))
			      (set! func-ok (caddr new-vars))))))

		      (and (= (length sel) (length pat))             ; march through selector and current target matching elements
			   func-ok
			   (call-with-exit
			    (lambda (return)
			      (for-each 
			       (lambda (sel-item pat-item)
				 (or (equivalent? sel-item pat-item) ; items match

				     (and (or (pair? pat-item)       ; recursive check (* (+ #<symbol?> 1) 2), pat-item: (+ #symbol?> 1)
					      (vector? pat-item))    ; pat-item, not sel-item here so pat-item can cover anything (a list for example)
					  ((handle-sequence pat-item e) sel-item))

				     (handle-pattern sel-item pat-item e)

				     (return #f)))                   ; else give up (selector does not match target)
			       sel pat)
			      
			      ;; dotted list, check final cdr
			      (unless (or (not (pair? sel)) 
					  (proper-list? sel))
				(let ((sel-item (list-tail sel (abs (length sel))))
				      (pat-item (list-tail pat (abs (length pat)))))
				  (return (or (equivalent? sel-item pat-item)
					      (handle-pattern sel-item pat-item e)))))
				      
			      #t)))))))

	   (define (find-labelled-pattern tree)
	     ;; walk body looking for a labelled pattern
	     (or (undefined? tree)
		 (and (pair? tree)
		      (or (find-labelled-pattern (car tree))
			  (find-labelled-pattern (cdr tree))))
		 (and (vector? tree)
		      (let vector-walker ((pos 0))
			(and (< pos (length tree))
			     (or (undefined? (tree pos))
				 (and (pair? (tree pos))
				      (find-labelled-pattern (tree pos)))
				 (and (vector? (tree pos))
				      (vector-walker (tree pos)))
				 (vector-walker (+ pos 1))))))))

	   (define (handle-body select body return e)
	     (if (null? body)
		 (return select))

	     (when (find-labelled-pattern body) ; if labelled, remake the body substituting the labelled-exprs for the labels
	       (set! body (let pair-builder ((tree body))
			    (cond ((undefined? tree)
				   (let ((label (let ((str (object->string tree)))
						  (substring str 2 (- (length str) 1)))))
				     (or (labels label) tree)))
				  
				  ((pair? tree)
				   (cons (pair-builder (car tree))
					 (pair-builder (cdr tree))))
				  
				  ((vector? tree)
				   (vector (map pair-builder tree)))
				  
				  (else tree)))))
		 
	     ;; evaluate the result (case* expands into a call on case*-helper; we need to evaluate the result expressions ourselves)
	     (return (eval (if (null? (cdr body))
			       (car body)
			       (if (eq? (car body) '=>)
				   (list (cadr body) select)
				   (cons 'begin body)))
			   e)))
		
	   ;; case*-helper
	   (lambda (select clauses e)
	     (call-with-exit
	      (lambda (return)
		(for-each
		 (lambda (clause)                                        ;((target...) body...)
		   (let ((targets (car clause))
			 (body (cdr clause)))
		     (fill! labels #f)                                   ; clear previous labels
		     (if (memq targets '(else #t))                       ; (else...) or (#t...)
			 (return (eval (cons 'begin body) e))
			 (for-each
			  (lambda (target)
			    (if (or (equivalent? target select)
				    (and (undefined? target)              ; #<...>
					 (not (eq? target #<undefined>))
					 (let ((func (undefined->function target e)))
					   ;(format *stderr* "func: ~S~%" func)
					   ;; (if (undefined? func) (error 'unbound-variable "function ~A is undefined\n" str))
					   ;; not the above check because we want to be able to pass patterns as selectors! (scase37 in s7test)
					   ;;    this seems like a mistake: #<symbol?> won't work? 
					   (and (procedure? func)
						(func select))))
				    (and (sequence? target)
					 ((handle-sequence target e) select)))
				(handle-body select body return e)))
			  targets))))
		 clauses)))))))
    ;; case*
    (#_macro (selector . clauses)
      `(((#_funclet 'case*) 'case*-helper) ,selector ',clauses (#_curlet)))))


;;; --------------------------------------------------------------------------------

#|
;;; there are more tests in s7test.scm

(define-macro (test expr res)
  `(let ((value ,expr))
     (unless (equivalent? value ,res)
       (format *stderr* "~S, expected: ~S, got: ~S~%" ',expr ,res value))))

(define (scase x)
 (case* x
   ((a b) 'a-or-b)
   ((1 2/3 3.0) => (lambda (a) (* a 2)))
   ((pi) 1 123)
   (("string1" "string2"))
   ((#<symbol?>) 'symbol!)
   (((+ x #<symbol?>)) 'got-list)
   ((#(1 x 3)) 'got-vector)
   (((+ #<>)) 'empty)
   (((* #<x:symbol?> #<x>)) 'got-label)
   (((#<> #<x:> #<x>)) 'repeated)
   (((#<symbol?> #<symbol?>)) 'two)
   (((#<x:> #<x>)) 'pair)
   ((#(#<x:> #<x>)) 'vector)
   ((#(#<symbol?> #<...> #<number?>)) 'vectsn)
   ((#(#<...> #<number?>)) 'vectstart)
   ((#(#<string?> #<char-whitespace?> #<...>)) 'vectstr)
   (else 'oops)))

(test (scase 3.0) 6.0)
(test (scase 'pi) 123)
(test (scase "string1") "string1")
(test (scase "string3") 'oops)
(test (scase 'a) 'a-or-b)
(test (scase 'abc) 'symbol!)
(test (scase #()) 'oops)
(test (scase '(+ x z)) 'got-list)
(test (scase #(1 x 3)) 'got-vector)
(test (scase '(+ x 3)) 'oops)
(test (scase '(+ x)) 'empty)
(test (scase '(* z z)) 'got-label)
(test (scase '(* z x)) 'oops)
(test (scase '(+ (abs x) (abs x))) 'repeated)
(test (scase '(+ (abs x) (abs y))) 'oops)
(test (scase '(a b)) 'two)
(test (scase '(1 1)) 'pair)
(test (scase '(1 1 2)) 'oops)
(test (scase #(1 1)) 'vector)
(test (scase #(a b c 3)) 'vectsn)
(test (scase #(1 b 2)) 'vectstart)
(test (scase #("asdf" #\space +nan.0 #<eof>)) 'vectstr)
(test (scase #(a 3)) 'vectsn)
(test (scase #(1)) 'vectstart)
(test (scase #("asdf" #\space)) 'vectstr)
(test (scase #("asdf")) 'oops)

(define (scase3 x)
  (let ((local-func (lambda (target) (eqv? target 1))))
    (case* x
	   ((2 3 a) 'oops)
	   ((#<local-func>) 'yup))))
(test (scase3 2) 'oops)
(test (scase3 32) #<unspecified>)
(test (scase3 1) 'yup)

(define (ecase x)
  (case* x
    (((#<symbol?> #<...> #<symbol?>)) 'both-symbol)
    (((#<symbol?> #<...>)) 'car-symbol)
    (((#<...> #<symbol?> #<symbol?>)) 'two-symbols)
    (((#<...> #<symbol?>)) 'end-symbol)
    (else #f)))

(test (ecase '(a b 1)) 'car-symbol)
(test (ecase '(1 2 c)) 'end-symbol)
(test (ecase '(a 1 2 3 c)) 'both-symbol)
(test (ecase '(1 2 3 b c)) 'two-symbols)

(define (palindrome? x) ; x can be a list or a vector
  (case* x
    ((() (#<>) #() #(#<>)) 
     #t)
    (((#<x:> #<middle:...> #<x>) #(#<x:> #<middle:...> #<x>))
     (palindrome? #<middle>))
    (else #f)))

(test (palindrome? '(a b a)) #t)
(test (palindrome? '(a b c a)) #f)
(test (palindrome? '(a b c b a)) #t)
(test (palindrome? #(a b a)) #t)
(test (palindrome? #(a b c a)) #f)
(test (palindrome? #(a b c b a)) #t)

(define (scase15 x)
  (case* x
    (((+ #<x:> #<x>)) (* 2 #<x>))
    (((#<x:> #<y:>)) (list #<y> #<x>))
    (else 'oops)))
(test (scase15 '(1 2)) '(2 1))
(test (scase15 '(+ 1 1)) 2)
(test (scase15 '(+ (* 2 3) (* 2 3))) 12)

(define (scase16 x)
  (case* x
   (((+ (* #<symbol?> 2) 3)) 0)
   (else 1)))
(test (scase16 '(+ (* y 2) 3)) 0)
(test (scase16 '(+ (* y 1) 3)) 1)

(define (scase17 x)
  (let ((a1 3))
    (case* x
      (((+ #<add1:symbol?> (* #<mul1:number?> 2))) (+ #<mul1> (* #<add1> 2)))
      (else 'oops))))
(test (scase17 '(+ a1 (* 5 2))) 11)

(define (case-reverse x) ; maybe the least efficient reverse ever
  (case* x
    (((#<>) ()) x)
    (((#<first:> #<rest:...>))
     (append (case-reverse #<rest>)
	     (list (quote #<first>))))))
(test (case-reverse '(a b c)) '(c b a))
(test (case-reverse '(a b)) '(b a))

(define (scase19 x)
  (case* x
    (((#<integer?> . #<symbol?>)) 'ok)
    (else #f)))
(test (scase19 (cons 1 'a)) 'ok)
(test (scase19 (list 1 'a)) #f)

(define (scase20 x)
  (case* x
   ((#(+ (* #<symbol?> 2) 3)) 0)
   (else 1)))
(test (scase20 #(+ (* y 2) 3)) 0)
(test (scase20 #(+ (* y 1) 3)) 1)

(define (scase21 x)
  (let ((pair2? (lambda (p) 
		  (= (length p) 2))))
    (case* x
      (((+ #<pair2?> 3)) #t)
      (else #f))))
(test (scase21 '(+ (abs x) 3)) #t)
(test (scase21 '(+ (* 2 x) 3)) #f)

(define (scase22 x)
  (letrec ((symbols? 
	    (lambda (x)
	      (or (null? x)
		  (and (pair? x)
                       (symbol? (car x))
		       (symbols? (cdr x)))))))
  (case* x
    ((#<symbols?>) #t)
    (else #f))))
(display (scase22 '(+ a b c))) (newline)
(display (scase22 '(+ a b 3))) (newline)

(define (scase23 x)
  (let ((numeric-op? (lambda (x)
		       (let ((func (symbol->value x)))
			 (and (signature func)
			      (memq (car (signature func)) '(number? complex? real? float? rational? integer? byte?)))))))
    (case* x
      (((#<numeric-op?> #<number?>)
	(#<numeric-op?> #<number?> #<number?>)) #t)
      (else #f))))
(display (scase23 '(+ 1 2))) (newline)
(display (scase23 '(floor 32.1))) (newline)
(display (scase23 '(abs))) (newline)

(define (scase24 x)
  (case* x
    (((+ #<rest:...>))
     (+ (apply values #<rest>)))
    (else 'oops)))
(display (scase24 '(+ 1 2 3))) (newline)
(display (let ((a 1) (b 2) (c 3)) (scase24 `(+ ,a ,b ,c)))) (newline)

(define (scase25 x)
  (case* x
    (((#<symbol?> #<ellip1:...> (+ #<ellip2:...>))) (append #<ellip1> #<ellip2>))
    (else #f)))
(display (scase25 '(a b c d (+ 1 2)))) (newline)

(define (scase26 x)
  (case* x
    (((if (not #<test:>) (begin #<body:...>))) (cons 'unless (cons '#<test> #<body>)))
    (((if (not #<test:>) #<body:>))            (cons 'unless (list '#<test> '#<body>)))
    (((if #<test:> (begin #<body:...>)))       (cons 'when (cons '#<test> #<body>)))
    (((if #<test:> #<body:>))                  (cons 'when (list '#<test> '#<body>)))))

(display (scase26 '(if (not (> i 3)) (display i)))) (newline)                   ; '(unless (> i 3) (display i))
(display (scase26 '(if (not (> i 3)) (begin (display i) (newline))))) (newline) ; '(unless (> i 3) (display i) (newline))
(display (scase26 '(if (> i 3) (display i)))) (newline)                         ; '(when (> i 3) (display i))
(display (scase26 '(if (> i 3) (begin (display i) (newline))))) (newline)       ; '(when (> i 3) (display i) (newline))

(define (scase27 x)
  (let ((efunc? (lambda (x)
		  (and (pair? x)
		       (number? (car x))))))
    (case* x
      (((#<label,efunc?:...>)) #t)
      (else #f))))
(display (scase27 '(1 2 3))) (newline)
(display (scase27 '(a 2 3))) (newline)
(display (scase27 '(3))) (newline)
(display (scase27 ())) (newline)

(define (scase29 x)
  (let ((match? ((funclet 'case*) 'case*-match?)))
    (let ((multiplier? (lambda (x)
			 (or (match? x '(* 1 #<integer?>))
			     (match? x '(* 2 #<integer?>))))))
    (case* x
      (((+ #<integer?> #<multiplier?> #<integer?>)) #t)
      (else #f)))))

(display (scase29 '(+ 1 (* 1 2) 3))) (newline)
(display (scase29 '(+ 1 (* 3 2) 3))) (newline)

(define (scase30 x)
  (let ((match? ((funclet 'case*) 'case*-match?)))
    (match? x '(+ #<symbol?> 1))))

(display (scase30 '(+ a 1))) (newline)
(display (scase30 '(+ 1 1))) (newline)

(define* (scase31 x (e (curlet)))
  (let ((match? ((funclet 'case*) 'case*-match?))
        (labels ((funclet 'case*) 'case*-labels)))
    (and (match? x '(#<symbol?> #<ellip1:...> (+ #<ellip2:...>)))
         (append (cadr (labels 'ellip1)) (cadr (labels 'ellip2))))))

(display (scase31 '(a b c d (+ 1 2)))) (newline)

(define (scase32 x)
  (let ((match? ((funclet 'case*) 'case*-match?))
        (labels ((funclet 'case*) 'case*-labels)))
    (if (match? x '(if #<test:> (begin #<body:...>)))
	(cons 'when (cons (labels 'test) (cadr (labels 'body)))))))

(display (scase32 '(if (> i 3) (begin (display i) (newline))))) (newline)
(display (scase32 '(if 32/15 (begin (display i) (newline))))) (newline)

(define (scase33 x)
  (case* x
    ((#<"a.b">) #t)
    (else #f)))

(display (scase33 "a1b")) (newline)
(display (scase33 "abc")) (newline)
(display (scase33 "a123b")) (newline)
(display (scase33 'a1b)) (newline)

(define (scase34 x)
  (case* x
    ((#<reg:"a.b">) #<reg>)
    (else #f)))

(display (scase34 "a1b")) (newline)

(define (scase35 x)
  (let ((quotes? (lambda (x)
		   (char-position #\" x))))
    (case* x
      ((#<"^dog">) 'dog0)
      ((#<"gray\|grey">) 'graey) ; basic regex so it needs \, apparently doesn't work in OSX?
      ((#<"h\(a\|e\)y">) 'haey) 
      ((#<"p[ae]y">) 'paey)
      ((#<"b[aeiou]bble">) 'bxbble)
      ((#<"z\{3,6\}">) 'zzz)
      ((#<"\d">) 'digit)
      ((#<"<>">) 'brackets)
      ((#<quotes?>) 'quotes)
      ((#<"[^i*&2@]">) 'not-i)
      (else #f))))

(display (scase35 "dog")) (newline)
(display (scase35 "i7+")) (newline)
(display (scase35 "gray")) (newline)
(display (scase35 "hay")) (newline)
(display (scase35 "pay")) (newline)
(display (scase35 "bubble")) (newline)
(display (scase35 "ab0d")) (newline)
(display (scase35 "+-<>-+")) (newline)
(display (scase35 "zzzz")) (newline)
(display (scase35 (string #\a #\"))) (newline)

;;; for other types:
(define (hlt x)
  (case* (with-input-from-string (object->string x) read)
    (((hash-table 'a #<integer?>)) 'hash-table)
    (((inlet 'a #<integer?>)) 'inlet)
    (else #f)))

(display (hlt (inlet 'a 1))) (newline)
(display (hlt (hash-table 'a 1))) (newline)

(append (list 'float-vector) (vector->list #r(1 2 3))): (float-vector 1.0 2.0 3.0)

|#