;;;;;;;;;;;;;;;;; PAGE 1

;; The aim is to convert an infix expression to prefix
;;    like (1 + 2 * 4 + 3) into (+ 1 (* 2 4) 3)
;;
;; Operator precedence is important, we shall bracket things in the order
;; (/ * - +)
;;

;; I suppose the first thing to code is take an expression like (1 * 3) into (* 1 3)
;; ill call this infix->prefix-single

(defun infix->prefix-single (infix-expression)
  (list (second infix-expression)
        (first infix-expression)
        (third infix-expression)))

;; seems to work
;; (infix->prefix-single '(1 + 2)) => (+ 1 2)

;; I would rather put second first and third together in a list,
;; instead of rewriting infix-expression everytime..  so ill use mapcar for that:

(defun infix->prefix-single (infix-expression)
  (mapcar (lambda (f) (funcall f infix-expression))
          '(second first third)))

;; for a first attempt, ill ignore operator precedence and just parse things the APL way
;; so (2 * 3 + 7 / 2 + 1) is read like (2 * (3 + (7 / (2 + (1)))))

;; for a given exp like the one above, we have 2, * (3 + 7 / 2 + 1),
;; thats the car cadr and cddr respectively see #1 for a note on car cdr cadr etc

(defun apl-infix->prefix (expression)
  (infix->prefix-single
   (list (car expression)
         (cadr expression)
         (cddr expression))))

;; bah deja-vu except it needs to work recursively on the cddr
;; (so I cant and shouldnt use mapcar like I did with infix->prefix-single),
;; except when the input is a single element (e.g. a list with null cdr)

(defun apl-infix->prefix (expression)
  (cond ((null (cdr expression)) expression)
        (t (infix->prefix-single
            (list (car expression)
                  (cadr expression)
                  (apl-infix->prefix (cddr expression)))))))

;; ok that was fun :/... now how to handle precedence
;; well when you look at the APL version, its clear in the t part of the cond that the current
;; operator (the cddr) is the one applied last if the final expression would be evaluated,
;; so what we should probably do is first transform the operator with lowest precedence
;; in the example before '(2 * 3 + 7 / 2 + 1)
;; the next stage should be (list '+ (infix->prefix '(2 * 3))
;;                                   (infix->prefix '(7 / 2 + 1)))
;; 
;; The best way to proceed would be to define a list with the operators in order, and a function to
;; find the index of op with least precedence in an expression

(defparameter *operators* '(+ - * /))

(defun find-lowest-precedence-operator (expression)
  (or (position (first *operators*) expression)
      (position (second *operators*) expression)
      (position (third *operators*) expression)
      (position (fourth *operators*) expression)))

;; silly to be so repitious...
;; I could just use dolist to perform some code for each operator

(defun find-lowest-precedence-operator (expression)
  (dolist (operator *operators*)
    (let ((index (position operator expression)))
      (when index (return-from find-lowest-precedence-operator index)))))

;; well you cant map with or (its a macro not a function) so the 'some' function should work
;; I dont rely on any of the forms not being evaluated if a previous one is true

(defun find-lowest-precedence-operator (expression)
  (some #'identity
        (list (position (first *operators*) expression)
              (position (second *operators*) expression)
              (position (third *operators*) expression)
              (position (fourth *operators*) expression))))

(defun find-lowest-precedence-operator (expression)
  (some #'identity
        (mapcar (lambda (operator)
                  (position operator expression))
                *operators*)))


;; hm I spent so long writing this function I forget what it would be used for...
;; I guess I want to find everything before it and everything after it, as well as the operator

(defun split (list index)
  (assert (<= 0 index (1- (length list)))
          () "Cannot split before or after the bounds of the list")
  (values (subseq list 0 index)
          (elt list index)
          (subseq list (1+ index))))


;; time for a shot at the final function

(defun infix->prefix (expression)
  (let ((split-index (find-lowest-precedence-operator expression)))
    (cond (split-index (multiple-value-bind (before operator after) (split expression split-index)
                         (list operator
                               (infix->prefix before)
                               (infix->prefix after))))
          (t (car expression)))))

;; and it works!

; CL-USER> (infix->prefix '(2 * 3 + 7 / 2 + 1))
; (+ (* 2 3) (+ (/ 7 2) 1))
; CL-USER> (+ (* 2 3) (+ (/ 7 2) 1))
; 21/2

; mr-dos-computer:~ ed$ bc -lq
; (2 * 3 + 7 / 2 + 1)
; 10.50000000000000000000

;; looking back theres a large amount of code which I actually dont use,
;; it was just used in the thinking process













;;;;;;;;;;;;;;;;;;;; PAGE 2

;; It could probably be written better though, its a bit silly for stuff like

; CL-USER> (infix->prefix '(1 + 2 + 3 + 4))
; (+ 1 (+ 2 (+ 3 4)))

;; and fixing that would be a whole new stage of optimisation (pattern matching and transformation)
;; on the expression

;; in lisp the numeric operators work on several numbers like,
;; (+ 1 2 3 4) means the same as the thing before.
;; Infact here are some optimisation rules that could apply to any numeric expressions
;;
;; (+ (+ a b) c) = (+ a (+ b c)) = (+ a b c)
;; (* (* a b) c) = (* a (* b c)) = (* a b c)
;; (- (+ a b) c) = (- a (+ b c)) = (- a b c)
;; (/ (* a b) c) = (/ a (* b c)) = (/ a b c)

;; we could probably write a little pattern matcher and transformer so optimisation could be
;; written like that infact it could work for transforming infix to prefix as well!

;; (a + b) -> (+ a b)
;; (a - b) -> (- a b)
;; (a * b) -> (* a b)
;; (a / b) -> (/ a b)


;; in order to do that ill need a function that takes an expression,
;; a pattern/template and if the expression matches the template return a list of bindings
;; (in the examples a b and c are any expression), so I could
;; get the values of the variables in the template
;; also, the syntax should describe the pattern better (how do we know a is a variable and + isnt)
;; ill use (? _) where _ is any symbol, to donate a variable (it should match anything except nil),
;; anything else can be a literal

;; to match, we should check if we have a variable in the pattern
;; (and if so supply a binding for it and check it doesnt conflict with previous bindings)
;; otherwise we just need to check if the car matches, and if the cdr matches

(defun pattern-variable-p (exp)
  (and (consp exp)
       (eq '? (car exp))
       (cadr exp)))

(defun assoc-conflict (variable-value alist)
  (let ((value (assoc (car variable-value) alist)))
    (if value (not (equal (cdr variable-value) (cdr value))))))

(defun match (pattern expression &optional bindings)
  (cond ((pattern-variable-p pattern) ;; we have a pattern variable, so check if the thing isnt null
         ;; and if so make a new binding,
         ;; check it doesnt conflict then cons it onto the bindings alist
         (when (not (null expression))
           (let ((new-binding (cons (pattern-variable-p pattern) expression)))
             (unless (assoc-conflict new-binding bindings)
               (values t (cons new-binding bindings))))))
        ((atom pattern) ;; just check the equality and return the bindings if they are equal
         (when (equal pattern expression)
           (values t bindings)))
        (t ;; we know the pattern is a cons so check the car and cdr
         (unless (atom expression)
           (if (pattern-variable-p (car pattern))
               ;; if we have a pattern variable, we can matching a bit more
               ;; e.g. ((? x) z) matches (x y z) to bind x to (y z)
               ;; so try every sublist
               (loop for sublist-length from 0 to (length expression)
                  do (let ((before (subseq expression 0 sublist-length))
                           (after (subseq expression sublist-length)))
                       (multiple-value-bind (success bindings) (match (car pattern) before bindings)
                         (when success
                           (multiple-value-bind (success bindings) (match (cdr pattern) after bindings)
                             (when success (return-from match (values success bindings))))))))
               ;; check the car and cdr are match and bindings dont conflict etc
               (multiple-value-bind (success bindings) (match (car pattern) (car expression) bindings)
                 (when success
                   (multiple-value-bind (success bindings) (match (cdr pattern) (cdr expression) bindings)
                     (when success
                       (return-from match (values success bindings)))))))))))

;; so now its simple to do somthing like,

;CL-USER> (match '((? x) + (? y)) '(1 / 2 + 3 * 7))
;T
;((Y 3 * 7) (X 1 / 2))

;; so we just need somthing which takes a list of patterns then binds the values
;; and runs the body, a lot like cond

#|
(pattern-cond exp
  (((? x) + (? y)) `(+ ,(infix->prefix x) ,(infix->prefix y)))
  (((? x) - (? y)) `(- ,(infix->prefix x) ,(infix->prefix y)))
  (((? x) * (? y)) `(* ,(infix->prefix x) ,(infix->prefix y)))
  (((? x) / (? y)) `(/ ,(infix->prefix x) ,(infix->prefix y))))
|#

;; This way it should handle operator precedence as well
;; In order to write it ill consider what it might expand to

#|
(pattern-cond <exp>
  (<pattern-1> <consequence-1>)
  ...)

(let* (bindings)
  (cond ((multiple-value-bind (matched values) (match <pattern-1> <exp>)
           (setq bindings values)
           matched)
         (progv (mapcar #'car bindings) (mapcar #'cdr bindings)
           <consequence-1>))
        ...))
|#

(defmacro pattern-cond (expression &rest clauses)
  (let ((bindings (gensym "bindings")))
    (labels ((make-cond-clauses (clauses)
               (when clauses
                 (if (eq 'else (caar clauses))
                     `((t ,@(cdar clauses)))
                     (cons `((multiple-value-bind (matched values)
                                 (match ',(caar clauses) ,expression)
                               (setq ,bindings values)
                               matched)
                             (progv (mapcar #'car ,bindings) (mapcar #'cdr ,bindings)
                               ,@(cdar clauses)))
                           (make-cond-clauses (cdr clauses)))))))
      `(let* (,bindings)
         (cond ,@(make-cond-clauses clauses))))))

(defun infix->prefix-convert (expression)
  (pattern-cond expression
    (((? x) + (? y)) `(+ ,(infix->prefix x) ,(infix->prefix y)))
    (((? x) - (? y)) `(- ,(infix->prefix x) ,(infix->prefix y)))
    (((? x) * (? y)) `(* ,(infix->prefix x) ,(infix->prefix y)))
    (((? x) / (? y)) `(/ ,(infix->prefix x) ,(infix->prefix y)))
    (else (if (null (cdr expression))
              (car expression)
              expression))))

;CL-USER> (infix->prefix-convert '(1 * 3 + 4))
;(+ (* 1 3) 4)
;CL-USER> (infix->prefix-convert '(1 * (3 + 4)))
;(* 1 (+ 3 4))
;CL-USER> (infix->prefix-convert '(1 / (3 * 4 * 5)))
;(/ 1 (* 3 (* 4 5)))

;; Oh yeah, just one more thing to do, the optimisation

(defun infix->prefix-optimize (expression)
  (infix->prefix-optimize
   (pattern-cond expression
     ((+ (+ (? x) (? y)) (? z)) `(+ ,x ,y ,z))
     ((+ (? x) (+ (? y) (? z))) `(+ ,x ,y ,z))
     ((* (* (? x) (? y)) (? z)) `(* ,x ,y ,z))
     ((* (? x) (* (? y) (? z))) `(* ,x ,y ,z))
     ((- (+ (? x) (? y)) (? z)) `(- ,x ,y ,z))
     ((- (? x) (+ (? y) (? z))) `(- ,x ,y ,z))
     ((/ (* (? x) (? y)) (? z)) `(/ ,x ,y ,z))
     ((/ (? x) (* (? y) (? z))) `(/ ,x ,y ,z))
     (else (return-from infix->prefix-optimize expression)))))

;CL-USER> (infix->prefix-optimize '(+ 1 2 (+ (+ 3 4) 5)))
;(+ (1 2) (+ 3 4) 5)

;; its pretty ugly and hard to read, with some repetition as well
;; we could fix it by making new pattern variables, like ill use
;; ?^ to say this is certainly a list 

(defun pattern-variable-p (exp)
  (and (consp exp)
       (or (eq '? (car exp)) (eq '?^ (car exp)))
       (cadr exp)))

(defun match (pattern expression &optional bindings)
  (cond ((pattern-variable-p pattern) ;; we have a pattern variable, so check if the thing isnt null
         ;; and if so make a new binding, check it doesnt conflict then cons
         ;; it onto the bindings alist

         (when (or (not (null expression))
                   (eq '?^ (car pattern)))
           (let ((new-binding (cons (pattern-variable-p pattern) expression)))
             (unless (assoc-conflict new-binding bindings)
               (values t (cons new-binding bindings))))))
        ((atom pattern) ;; just check the equality and return the bindings if they are equal
         (when (equal pattern expression)
           (values t bindings)))
        (t ;; we know the pattern is a cons so check the car and cdr
         (unless (and (atom expression) (not (null expression)))
           (if (pattern-variable-p (car pattern))
               ;; if we have a pattern variable, we can matching a bit more
               ;; e.g. ((? x) z) matches (x y z) to bind x to (y z)
               ;; so try every sublist (except we dont need to try the one with length 1,
               ;; it was tested already)
               (loop for sublist-length from 0 to (length expression)
                  do (let ((before (subseq expression 0 sublist-length))
                           (after (subseq expression sublist-length)))
                       (multiple-value-bind (success bindings) (match (car pattern) before bindings)
                         (when success
                           (multiple-value-bind (success bindings) (match (cdr pattern) after bindings)
                             (when success (return-from match (values success bindings)))))))))
           ;; check the car and cdr are match and bindings dont conflict etc
           (multiple-value-bind (success bindings) (match (car pattern) (car expression) bindings)
             (when success
               (multiple-value-bind (success bindings) (match (cdr pattern) (cdr expression) bindings)
                 (when success
                   (return-from match (values success bindings))))))))))

(defun infix->prefix-optimize (expression)
  (infix->prefix-optimize
   (pattern-cond expression
     ((+ (?^ x) (+ (?^ y)) (?^ z)) `(+ ,@x ,@y ,@z))
     ((* (?^ x) (* (?^ y)) (?^ z)) `(+ ,@x ,@y ,@z))
     ((- (?^ x) (+ (?^ y)) (?^ z)) `(- ,@x ,@y ,@z))
     ((/ (?^ x) (* (?^ y)) (?^ z)) `(/ ,@x ,@y ,@z))
     (else (return-from infix->prefix-optimize expression)))))

(defun infix->prefix (expression)
  (labels ((convert (expression)
             (pattern-cond expression
               (((? x) + (? y)) `(+ ,(infix->prefix x) ,(infix->prefix y)))
               (((? x) - (? y)) `(- ,(infix->prefix x) ,(infix->prefix y)))
               (((? x) * (? y)) `(* ,(infix->prefix x) ,(infix->prefix y)))
               (((? x) / (? y)) `(/ ,(infix->prefix x) ,(infix->prefix y)))
               (else (if (null (cdr expression))
                         (car expression)
                         expression))))
           (optimize (expression)
             (optimize
              (pattern-cond expression
                ((+ (?^ x) (+ (?^ y)) (?^ z)) `(+ ,@x ,@y ,@z))
                ((* (?^ x) (* (?^ y)) (?^ z)) `(* ,@x ,@y ,@z))
                ((- (?^ x) (+ (?^ y)) (?^ z)) `(- ,@x ,@y ,@z))
                ((/ (?^ x) (* (?^ y)) (?^ z)) `(/ ,@x ,@y ,@z))
                (else (return-from optimize expression))))))
    (optimize (convert expression))))


;; appendix

;;   #1 car cdr cadr etc
;; a cons has a car and a cdr, for example
;; (car (cons 'x 'y)) => x
;; (cdr (cons 'x 'y)) => y
;; for a list the car is the head and the cdr is the tail
;; so (car (list 'x 'y 'z)) => x
;;    (cdr (list 'x 'y 'z)) => (y z)
;;
;; (cadr o) = (car (cdr o)) and so on for all the combinations of c{a,d}r