(scan-variation) behaves strangely

gistfile1.txt

(in-package :pgn-tools)

(defun read-file (infile)
  (with-open-file (instream infile
			    :direction
			    :input :if-does-not-exist nil)
    (when instream 
      (let ((string (make-string (file-length instream))))
        (read-sequence string instream)
        string))))


(defun bind (f &rest args)
  (lambda (&rest more-args)
    (apply f (concatenate 'list args more-args))))

(defun bamboozle (scanner message &key (verbose nil))
  (lambda (stream)
    (format t "~A" message)
    (when verbose
      (format t " position: ~D" (file-position stream)))
    (terpri)
    (funcall scanner stream)))

(defun skip-ws (stream)
  (peek-char t stream nil nil)
  t)

(defun ws ()
  #'skip-ws)

(defun spaced (scanner)
  (seq (ws) scanner))

(defun try-scan (scanner stream)
  (let ((org (file-position stream)))
    (if (funcall scanner stream)
	t
	(progn
	  (format t "try-scan fail at position ~D~%"
		  (file-position stream))
	  (file-position stream org)
	  nil))))

(defun scan-token (token stream )
  (let ((tl (length token)))
    (labels ((rec (i)
	       (if (and (< i tl)
			(equal (read-char stream nil)
			       (elt token i)))
		   (rec (1+ i))
		   (equal i tl))))
      (rec 0))))

(defun token (token)
  (bind #'scan-token token))
    
(defun seq (&rest scanners)
  (lambda (stream)
    (let ((org (file-position stream)))
      (labels ((rec (ss)
		 (if ss
		     (if (try-scan (car ss) stream)
			 (rec (cdr ss))
			 nil)
		     t)))
	(if (rec scanners)
	    t
	    (progn
	      (file-position stream org)
	      nil))))))

(defun alt (&rest scanners)
  (lambda (stream)
    (labels ((rec (alts)
	       (if alts
		   (if (try-scan (car alts) stream)
		       t
		       (rec (cdr alts)))
		   nil)))
      (rec scanners))))
      
(defun scan (scanner stream)
  (funcall scanner stream))

(defun scan-text (scanner text)
  (with-input-from-string (stream text)
    (scan scanner stream)))

(defun scan-result ()
  (alt (bind #'scan-token "*")
       (bind #'scan-token "1-0")
       (bind #'scan-token "0-1")))

(defun any-char-except (evil-chars stream)
  (if (find (peek-char nil stream nil) evil-chars)
      nil
      (read-char stream nil)))

(defun any-char-in (charset stream)
  (if (find (peek-char nil stream nil) charset)
      (read-char stream nil)
      nil))

(defun zero-or-more (scanner)
  (lambda (stream)
    (labels ((rec ()
	       (if (try-scan scanner stream)
		   (rec)
		   t)))
      (rec))))

(defun one-or-more (scanner)
  (seq scanner (zero-or-more scanner)))

(defun opt (scanner)
  (lambda (stream)
    (try-scan scanner stream)
    t))

(defun between (opener closer inner)
  (seq opener inner closer))

(defun scan-dq-string ()
  (between (token "\"")
	   (token "\"")
	   (zero-or-more (bind #'any-char-except "\""))))

(defun scan-tag ()
  (between (token "[")
	   (token "]")
	   (seq (one-or-more (bind #'any-char-except " "))
		#'skip-ws
		(scan-dq-string))))

(defun scan-eol-comment (stream)
  (if (equal (peek-char nil stream nil) #\;)
      (read-line stream)
      nil))

(defun scan-inline-comment ()
  (between (token "{")
	   (token "}")
	   (zero-or-more (bind #'any-char-except "}"))))

(defun scan-comment ()
  (alt #'scan-eol-comment (scan-inline-comment)))

(defun scan-digit ()
  (bind #'any-char-in "0123456789"))

(defun scan-digits ()
  (one-or-more (scan-digit)))

(defun scan-move-number-white ()
    (seq (scan-digits) (token ".")))

(defun scan-move-number-black ()
  (seq (scan-digits) (alt (token "...")
			  (seq (token ".") (token "..")))))

(defun scan-castling ()
  (alt (token "O-O-O")
       (token "O-O")))

(defun scan-chessman ()
  (bind #'any-char-in "PRNBQK"))

(defun scan-file ()
  (bind #'any-char-in "abcdefgh"))

(defun scan-rank ()
  (bind #'any-char-in "12345678"))

(defun scan-promotion ()
  (seq (token "=") (scan-chessman)))

(defun scan-move-suffix ()
  (alt (token "+")
       (token "#")
       (token "e.p.")))

(defun scan-pawn-move ()
  " e5 | exf6 | fxg8=Q+ | e8=R# ... "
  (seq (scan-file)
       (opt (seq (token "x") (scan-file)))
       (scan-rank)
       (opt (scan-promotion))
       (opt (scan-move-suffix))))

(defun scan-piece-move ()
  (seq (scan-chessman)
       (alt (seq (scan-file) (opt (token "x")) (scan-file)
		 (scan-rank))
	    (seq (scan-rank) (opt (token "x")) (scan-file)
		 (scan-rank))
	    (seq (opt (token "x")) (scan-file) (scan-rank)))
       (opt (scan-move-suffix))))

(defun scan-move ()
  (alt (scan-pawn-move) (scan-piece-move) (scan-castling)))

(defparameter *scan-variation* nil "break mutual recursion")

(defun scan-white-move ()
  (seq (spaced (scan-move-number-white))
       (spaced (scan-move))
       (zero-or-more (spaced (scan-comment)))
       (zero-or-more (spaced *scan-variation*))
       (opt (spaced (scan-move)))
       (zero-or-more (spaced (scan-comment)))
       (zero-or-more (spaced *scan-variation*))))

(defun scan-black-move ()
  (seq (spaced (scan-move-number-black))
       (spaced (scan-move))
       (zero-or-more (spaced (scan-comment)))
       (zero-or-more (spaced *scan-variation*))))

(defun scan-variation ()
  (between (token "(")
	   (token ")")
	   (bamboozle
	    (seq (one-or-more
		  (alt (spaced (scan-black-move))
		       (spaced (scan-white-move))))
		 (opt (scan-result)))
	    "inside variation" :verbose t)
	   ))

(setf *scan-variation* (scan-variation))


(defun scan-game ()
  (seq
   (zero-or-more (spaced (scan-tag)))
   (spaced (one-or-more (alt (spaced (scan-white-move))
			     (spaced (scan-black-move)))))
   (spaced (scan-result))))

;;(trace scan-game scan-black-move scan-white-move)
;;(untrace trace scan-game scan-black-move scan-white-move)

; tests for scanners

(defun test-scan-pawn-move ()
  (let ((test-cases
	 '("e4" "exd5" "e8=R" "exd5+" "e8=Q#"
	   "exf8=N#" "exd5e.p.")))
    (mapcar (lambda (m)
	      (with-input-from-string (stream m)
		(if (scan (scan-pawn-move) stream)
		    (format nil "~A PASSED" m)
		    (format nil "~A FAILED" m))))
	    test-cases)))

(defun test-scan-piece-move ()
  (let ((test-cases
	 '("Nf3" "Rad1" "R8a4" "R8xa4" "Rcxd4" "Nf7#"
	   "Nxf7#" "Bxf7+")))
    (mapcar (lambda (m)
	      (with-input-from-string (stream m)
		(if (scan (scan-piece-move)  stream)
		    (format nil "~A PASSED" m)
		    (format nil "~A FAILED" m))))
	    test-cases)))

(defun test-scan-game ()
  (let ((test-cases
	 (list
	  (read-file "/home/jochen/dev/cl/pgntools/test-game1.pgn")
	   )))
    (mapcar (lambda (g)
	      (with-input-from-string (stream g)
		(if (scan (scan-game) stream)
		    "PASSED"
		    (format nil "~A FAILED" g))))
	    test-cases)))