;;;; vmeta-ex.lsp - Some examples using vmeta.lsp
;;;;
;;;; This is *not* a test suite for vmeta.lsp: it makes no attempt to be
;;;; comprehensive.  It is just a collection of random examples.

(defmacro test (form &rest expected)
  `(let ((result (multiple-value-call #'list ,form)))
     (cond ((not (equal result ',expected))
	    (format t "error: ~s~%~4texpected values: ~s~%~4treturned values: ~s~%" ',form ',expected result))
	   (t
	    (format t "ok: ~s~%~4treturned values: ~s~%" ',form ',expected)
	    'ok))))

(deftype digit () '(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))

(defun ctoi (d) (- (char-code d) #.(char-code #\0)))

;; This not only parses integers, it returns their actual value.
(defun parse-int (sequence &optional (index 0) (end (length sequence))
			 &aux (s +1) d (n 0))
  ;; Lexical 'sequence', 'index', and 'end', as required by match.
  (and
   (match
    (seq
     (alt
      #\+
      (seq #\- (esc (setq s -1)))
      (seq))
     (type digit d)
     (esc (setq n (ctoi d)))
     (star (seq (type digit d)
		(esc (setq n (+ (* n 10) (ctoi d))))))))
   (* s n)))

(test (parse-int "105") 105)
(test (parse-int "-105") -105)
(test (parse-int "+105") +105)

;; The same thing, using the read macro characters.
(defun parse-int-mc (sequence &optional (index 0) (end (length sequence))
			   &aux (s +1) (n 0))
  (and
   (match
    [{#\+ [#\- !(setq s -1)] []}
     @(digit d) !(setq n (ctoi d))
     $[@(digit d) !(setq n (+ (* n 10) (ctoi d)))]])
   (* s n)))
(test (parse-int-mc "-105") -105)


(defun more-parse (sequence &optional (index 0) (end (length sequence))
			  &aux part1 sep1 part2 sep2 part3 d atend)
  (and
   (match
    (seq  (alt (name part1 "this") (seq))
	  (name sep1 (seq (star #\ )
			  (star (type digit d))))
	  (name part2 "and")
	  (name sep2 (star (type digit)))
	  (name part3 "that")
	  (esc (setq atend index))
	  (end)
	  ))
   (values t part1 sep1 part2 sep2 part3 atend end d)))


;; Test star and not

(defun test-star (sequence &optional (index 0) (end (length sequence)))
  (let (part1 sep1 part2 sep2 part3)
    (and
     (match
      (seq
       (name part1 (star "foo" 2))
       (name sep1  (star (alt #\ (type digit))))
       (name part2 (star "bar" 2 nil))
       (name sep2  (star (alt #\ (type digit))))
       (name part3 (star "baz" 2 3))
       (not "baz")
       ))
     (values t part1 sep1 part2 sep2 part3))))

(test (test-star "foofoo 1 3 barbarbar bazbazz")
      t "foofoo" " 1 3 " "barbarbar" " " "bazbaz")
(test (test-star "foofoo 1 3 barbarbar bazbazbazbaz")
      nil)


;; This works with the macro characters above.
(test (let ((s "foofoofoo  1 2 3  bazbazbaz"))
	(let (part1 sep part2 ch)
	  (and 
	   (match-expr s 
		       [%(part1 ^("foo" 1 nil))
			 %(sep ${#\ @digit})
			 %(part2 ^("baz" 1 2))
			 %(ch #\b)
			 ]
		       3 23)
	   (values t part1 sep part2 ch))))
      T "foofoo" "  1 2 3  " "baz" "b")

;; This is like the regexp "(foo)* *(bar|baz)*"
(test (match-expr "foofoofoo bazbazx" [$"foo" $#\ ${"bar" "baz"}]) T)

(test (match-expr "foofoofoo bazbazx" [$"foo" $#\ "bogus" $"baz"]) NIL)

(test (let (p)
	(match-expr "foofoofoo barbazbarbazx" 
		    [$"foo" $#\ %(p ${"bar" "baz"})])
	p)
      "barbazbarbaz")

#|

  Big hairy example from Baker's paper to parse common lisp numbers,
  changed just enough to use my version.
  
  ctoi and digit at at top of this file.

|#

(deftype sign () '(member #\+ #\-))

(deftype expmarker () '(member #\e #\s #\f #\d #\l #\E #\S #\F #\D #\L))

;; bogus make-float: show the actual pieces as parsed.
(defun make-float (m sign i f nf ex)
  `((m ,m) (sign ,sign) (i ,i) (f ,f) (nf ,nf) (ex ,ex)))

#| A real make-float would be something smarter than this
(defun make-float (m sign i f nf ex)
  (* sign (+ i (/ f (expt 10.0 nf))) (expt 10 ex)))
|#

(defun parse-number (sequence &optional (index 0) (end (length sequence))
			      &aux x (is #\+) id (i 0) dd (d 0)
			      fd (f 0) (nf 0) (es #\+) ed (e 0) (m #\e))
  ;; Parse CL real number according to [Steele90, 22.1.2]
  ;; Return 2 values; the number and a reversed list of lookahead characers.
  (match
   [{[@(sign is) !(push is x)] []}	                      ; scan sign.
    $[@(digit id) !(setq x nil i (+ (* i 10) (ctoi id)))]     ; integer digits.
    {[!id #\/ !(push #\/ x)		                      ; "/" -> ratio.
      $[@(digit dd) !(setq x nil d (+ (* d 10) (ctoi dd)))]]  ; denom. digits.
     [{[#\. {!id !(push #\. x)}		                      ; decimal point.
        $[@(digit fd)
	   !(setq x nil nf (1+ nf) f (+ (* f 10) (ctoi fd)))]]; fract. digits.
       []}
      {[{!id !fd} @(expmarker m) !(push m x)                  ; exp. marker.
	{[@(sign es) !(push es x)] []}	                      ; exponent sign.
	$[@(digit ed) !(setq x nil e (+ (* e 10) (ctoi ed)))]]; exp. digits.
       []}]}])
  (let ((sign (if (eql is #\-) -1 1))
	(ex (if (eql es #\-) (- e) e)))
    (values (cond ((or fd ed) (make-float m sign i f nf ex)) ; see [Clinger90]
		  (dd (/ (* sign i) d))
		  (id (* sign i))
		  (t nil))
	    x)))

(test (parse-number "-106.3050e23")
      ((M #\e) (SIGN -1) (I 106) (F 3050) (NF 4) (EX 23)) NIL)

(test (parse-number "1/236")
      1/236  NIL)

(test (parse-number "115") 115)

;; Examples for push:

(deftype alphachar () '(satisfies alpha-char-p))
(defun try-push (s)
  (let (ps cs (dd 0) d)
    (and (match-expr s 
		     [$(push ps {"foo" "bar" "baz"})
		       $#\space
		       $(push cs @alphachar)
		       {[#\space $[@(digit d) (esc (setq dd (+ (* dd 10)
							       (ctoi d))))]]
			[]}
		       ])
	 (values t ps cs dd))))
(test (try-push "foobarbaz bogus 1023")
      T ("baz" "bar" "foo") ("s" "u" "g" "o" "b") 1023)
(test (try-push "foobarbaz bogus")
      T ("baz" "bar" "foo") ("s" "u" "g" "o" "b") 0)


(defun try-push2 (s)
  (let (ps outcome)
    (match-expr s 
		[$[(push ps {"foo" "bar" "baz"}) "-x" #\space]
		 %(outcome {"wins" "loses"})])
    (values ps outcome)))

(test (try-push2 "-x wins")
      NIL NIL)
(test (try-push2 "foo-x wins")
      ("foo") "wins")
(test (try-push2 "foo-x bar-x baz-x wins")
      ("baz" "bar" "foo") "wins")
(test (try-push2 "foo-x baz-x wins")
      ("baz" "foo") "wins")
(test (try-push2 "foo-x bar-x baz-x loses")
      ("baz" "bar" "foo") "loses")
(test (try-push2 "foo-x baz-x does't know")
      ("baz" "foo") NIL)

(test (let (p1 p2)
	(match-expr "foo foo foo; and you too too you; and too you; and too; and you!" 
		    [%(p1 ["foo" $[#\space "foo"]])
		      ^([#\;
			 ^(#\space 1 nil)
			 (push p2 ["and"
				   ^([^(#\space 1 nil)
				       ${"you" "too"}
				       ] 1 nil)])
			 ])
		      ])
	(values p1 p2))
      "foo foo foo" ("and you" "and too" "and too you" "and you too too you"))

#|
Infinite loop:
(let (p) (match-expr "this; that; or the other" ()
		       ["this"
			$[{[^(#\space 1 nil)
			    "or"]
			   #\;}
			  ^(#\space 1 nil)
			  (push p ^((not #\;) 1 nil))]])
       (values t p))

This doesn't work
(let (p s)
    (and (match-expr "this; that; or the other" ()
		     ["this"
		      $[(push s [#\;
				 {[^(#\space 1 nil)
				    "or"]
				  []}])
			^(#\space 1 nil)
			(push p ^(@not-semi 1 nil))]])
	 (values t p s)))

|#


;; But this one does.
(deftype not-semi () '(not (eql #\;)))
(test (let (p s)
	(and (match-expr "this; that; or the other" 
			 ["this"
			  $[(push s [#\; ^(#\space 1 nil)
					 {["or" ^(#\space 1 nil)]
					  []}])
			    (push p ^(@not-semi 1 nil))]])
	     (values t p s)))
      T ("the other" "that") ("; or " "; "))




;; And this:
(deftype not-semi-comma () '(not (or (eql #\;) (eql #\,))))
(test (let (p s)
	(and (match-expr "this,  that, something else; or the other" 
			 ["this"
			  $[(push s [{#\; #\,} ^(#\space 1 nil)
				     {["or" ^(#\space 1 nil)]
				      []}])
			    (push p ^(@not-semi-comma 1 nil))]])
	     (values t p s)))
      T ("the other" "something else" "that") ("; or " ", " ",  "))



(deftype alphanumeric () '(satisfies alphanumericp))
(deftype not-space () '(not (eql #\space)))
(defun match-imap-status (sequence
			  &optional (index 0) (end (length sequence))
			  &aux id status rest)
  (and
   (match [%(id ^(@alphanumeric 1 nil))
	    #\space
	    %(status ^(@not-space 1 nil))
	    {[#\space %(rest ^(@character))] []}])
   (values t id status rest)))

(test (match-imap-status "a001 OK Interesting response.")
      T "a001" "OK" "Interesting response.")

(test (match-imap-status "bogusdatahere")
      NIL)