;; -*- Scheme -*-
;; arithm.scm -- Parsing simple arithmetic expressions.

;; CopyLeft 2005 Aaron Hawley
;; Written: October 11, 2005

;; MIT/GNU Scheme running under GNU/Linux
;; Copyright 2005 Massachusetts Institute of Technology.

;; This is free software; see the source for copying conditions.
;; There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A
;; PARTICULAR PURPOSE.

;; Image saved on Tuesday January 18, 2005 at 12:49:18 AM
;;   Release 7.7.90 || Microcode 14.11 || Runtime 15.3 || SF 4.41 ||
;;   LIAR 4.116
;You are in an interaction window of the Edwin editor.
;Type C-h for help.  C-h m will describe some commands.
;Package: (user)

(load-option '*parser)

;Loading "load.scm" -- done
;Loading "parser-unx.pkd" -- done
;Loading "shared.com" -- done
;Loading "matcher.com" -- done
;Loading "parser.com" -- done
;Value: *parser

;; exp -> number op exp* | number
(define read-infix-arithmetic-expression
  (*parser
    (alt
     (transform infix-vector->prefix-expression
      (seq
       read-number
       skip-any-whitespace
       read-infix-arithmetic-operator
       skip-any-whitespace
       read-infix-arithmetic-expression))
     read-number)))
;Value: read-infix-arithmetic-expression

; Notice that the top-level parser uses basic recursion and avoids
; recurring infinitely.  Here is an explanation of its design.
;
;   - Try reading an arithmetic expression.
;     - Try reading number.
;     - Try reading an operator.
;     - Try reading a recursive arithmetic expression.
;   - Else, try reading just a number.

;; op -> "+" | "-"
(define read-infix-arithmetic-operator
  (*parser
   (alt
    (seq (noise "+") (values '+))
    (seq (noise "-") (values '-)))))
;Value: read-infix-arithmetic-operator

;; num -> num* | "0" | "1" | "2" | ...
(define read-number
  (*parser
   (encapsulate vector-string->number
    (+
     (match (char-set char-set:numeric))))))
;Value: read-number

;; ws -> ws* | " "
(define skip-any-whitespace
  (*parser
   (* (noise " ")))) 
;Value: skip-any-whitespace

;; Ignore as "noise".

;; Auxiliary functions

;; infix-vector->prefix-expression :  token vector -> sexp vector
;;
;; Modifies a *parser vector in the following way:
;; #(exp1 op1 exp2) ==> #((op1 exp1 exp2))
;; Precedence rules are ignored.
(define (infix-vector->prefix-expression v)
  (vector (list (vector-ref v 1)
		  (vector-ref v 0)
		  (vector-ref v 2))))
;Value: infix-vector->prefix-expression

;; vector-string->string : string vector -> string
(define (vector-string->string v)
  (reduce string-append "" (vector->list v)))
;Value: vector-string->string

;; vector-string->number : string vector -> number
(define (vector-string->number v)
  (string->number (vector-string->string v)))
;Value: vector-string->number

;; Tests:

(infix-vector->prefix-expression #(1 + 2))
;Value 11: #((+ 1 2))

(read-number (string->parser-buffer "1"))
;Value 12: #(1)

(read-number (string->parser-buffer "12"))
;Value 13: #(12)

(read-infix-arithmetic-operator (string->parser-buffer "+"))
;Value 14: #(+)

(read-infix-arithmetic-operator (string->parser-buffer "1"))
;Value: ()

(read-infix-arithmetic-expression (string->parser-buffer "+ 1"))
;Value: ()

(read-infix-arithmetic-expression (string->parser-buffer "1 + 1"))
;Value 15: #((+ 1 1))

(read-infix-arithmetic-expression (string->parser-buffer "1 + 1 -"))
;Value 16: #((+ 1 1))

(read-infix-arithmetic-expression (string->parser-buffer "1 + 1 - 1 + 1"))
;Value 17: #((+ 1 (- 1 (+ 1 1))))

(read-infix-arithmetic-expression (string->parser-buffer "1 + 1 - 1 + 1"))
;Value 18: #((+ 1 (- 1 (+ 1 1))))

; This arithmetic parser still needs some error handling for parsing
; invalid arithmetic expressions.  Error handling situations include
; when the parser reaches an unexpected type of token or when
; unexpectedly parsing to the end of the input.  Neither of these are
; handed correctly above.

End of input stream reached
Happy Happy Joy Joy.