ashishnegi/shunting-algo.clj

## shunting-algo.clj
;; ------- Euler Functions ---------------
(set! *unchecked-math* true)

(def ToMod (int (+ 1000000000 7)))

(def toPrint false)

(defn myprintln [& args]
  (if toPrint
    (apply println args)))

(defn ^:static EulerPowNonMemoized ^long [^long x ^long p opr]
  ;; calculates the x ^ p efficiently for large p where p+2 is a prime number.
  (let [startVal (if (= opr +) 0 1)] ;; ASSUMPTION only + * would be passed.
    (loop [num (long startVal) toPow p localX x]
      (if (= 0 toPow)
        ;; just print out the results before returning num
        (do (myprintln " EulerPow : " num " for " x p)
            num)
        (let [squaredX (rem (opr localX localX) ToMod) ;; square successively
              halfToPow (bit-shift-right toPow 1)] ;; half the p successively
          (if (odd? toPow) ;; if toPow is odd then we should perform the opr on num with squared version.
            (recur (rem (opr num localX) ToMod)
                   halfToPow
                   squaredX)
            (recur num halfToPow squaredX)))))))

;; (defn ^:static  EulerPow ^long [^long x ^long y opr]
;;   ;; memoized version of EulerPow
;;   (memoize (EulerPowNonMemoized x y opr)))

(def EulerPow (memoize EulerPowNonMemoized))

;; + means multiplication and
;; * means power in EulerPow
;; (= 10 (EulerPow 2 5 +))
;; (= (* 19 254) (EulerPow 19 254 +))
;; (= 64 (EulerPow 2 6 *))
;; (= 27 (EulerPow 3 3 *))

;; since operands are put on the stack..
;; subtaction and division have second parameter as first operator.
;; does not make any thing different in add or mul.
(defn ^:static ModAdd ^long [^long x ^long y]
  (rem (+ x y) ToMod))

(defn ^:static ModSub ^long [^long x ^long y]
  (rem (- y x) ToMod))

(defn ^:static ModMul ^long [^long x ^long y]
  (if (> 0 y)
    (rem (- (EulerPow x (- y) +)) ToMod)
    (rem (EulerPow x y +) ToMod)))

;; (defn ModMul [^long x ^long y]
;;   (mod (* x y) ToMod))

(defn ^:static  ModDiv ^long [^long x ^long y]
  (ModMul y (EulerPow x (- ToMod 2) *)))

;; (ModDiv 4 2)

;; ------- splitting input functions ----------------

(defn split-with-delim [d s]
  (clojure.string/split
   s (re-pattern (str "(?=" d
                      ")|(?<=" d
                      ")"))))

;; making priorities
(def ^long plus-pri 2)
(def ^long minus-pri 2)
(def ^long mul-pri 4)
(def ^long div-pri 4)
(def ^long open-brac-pri 0) ;; open bracket would not remove anybody
(def ^long close-brac-pri 6) ;; close bracket would keep removing untill encountered close bracket
(def ^long unary-pri 10)

(defn make-calulator-list [s]
  (->> s
       ;; split into chars
       (split-with-delim #"[\/\+\-\*\(\) ]")
       ;; remove empty and spaces
       (filter #(not (or (= "" %) (= " " %))))
       ;; we can not remove unary +/- because ther can be -(((3)))
       ;; convert the numbers into tokens.
       ((fn [lst]
          (map (fn [x]
                 (if (= x "+")
                   [:plus-opr plus-pri ModAdd]
                   (if (= x "-")
                     [:minus-opr minus-pri ModSub]
                     (if (= x "*")
                       [:mul-opr mul-pri ModMul]
                       (if (= x "/")
                         [:div-opr div-pri ModDiv]
                         (if (= x "(")
                           [:open-bracket open-brac-pri]
                           (if (= x ")")
                             [:close-bracket close-brac-pri]
                             ;; this is just going to be a number not a vector
                             [:number (long (Long. x))])
                           ))))))
               lst)))

       ((fn [l]
          (let [fOpr (first (first l))]
            (if (= fOpr :plus-opr)
              (conj (rest l) [:unary-plus unary-pri ModAdd])
              (if (= fOpr :minus-opr)
                ;; convert into unary minus sign
                (conj (rest l) [:unary-minus unary-pri ModSub])
                l)))))

       ;; unary plus or minus
       ;; ++++2
       ;; ++--2
       ;; *+-2
       ;; *++2
       ;; (+

       ;; plus or minus
       ;; 2+
       ;; )+
       ((fn [l]
          (loop [lst (rest l) lastToken (first l) returnLst (list lastToken)]
            (do (myprintln lst lastToken returnLst)
                (if-not (first lst)
                  (reverse returnLst)
                  (let [lastOpr (first lastToken)
                        thisOpr (first (first lst))]
                    (if (or (= thisOpr :minus-opr) (= thisOpr :plus-opr))
                      (if-not (or (= lastOpr :close-bracket) (= lastOpr :number))
                        ;; this is unary plus or minus
                        (if (= thisOpr :minus-opr) ;; if i thought i was minus opr
                          (recur (rest lst) [:unary-minus unary-pri ModSub] (conj returnLst [:unary-minus unary-pri ModSub]))
                          ;; not adding + as it is of no use
                          (recur (rest lst) [:unary-plus unary-pri ModAdd] returnLst))
                        ;; this is normal
                        (recur (rest lst) (first lst) (conj returnLst (first lst))))
                      ;; this is normal
                      (recur (rest lst) (first lst) (conj returnLst (first lst)))
                      )))))
          ))


       doall))

(defn MakeRemoveAndProcessArray [F S]
  (loop [numStack F oprStack S m []]
    (let [fFirst (first numStack)
          sFirst (first oprStack)
          opr (first sFirst)]
      (if-not (and fFirst sFirst)
        (do (myprintln "\n** RemoveAnd Process Array : " m " For " S)
            (if sFirst
              (if (= opr :unary-minus)
                (conj m [0 sFirst])
                m)
              m))
        (if (= opr :unary-minus)
          (recur numStack (rest oprStack) (conj m [0 sFirst]))
          (recur (rest numStack) (rest oprStack) (conj m [fFirst sFirst])))))))

(defn ProcessNums [val oprAndVal]
  ;; val is last processed value of reduction
  ;; oprAndVal contains next operation and right side value to process.
  ;; oprAndVal is like [second-operand [operator-keyword operation-priority operation]
  (do (myprintln "ProcessNums " val oprAndVal)
      (if (and val (second oprAndVal))
        (let [opr (nth (second oprAndVal) 2)
              oprKeyword (first (second oprAndVal))
              secOperand (first oprAndVal)]
          (do (myprintln "ProcessNums"  val secOperand opr oprKeyword)
              (if (=  oprKeyword :unary-minus)
                (opr val 0)
                (opr val secOperand))))
        val)))

;; Now only optimization remaining is that of using unary operators and not doing n^2 in above algorithm of AddCloseBracketImmediately
(defn InfixToPrefix [infix*]
  (loop [numStack '() oprStack '() infix infix*]
    (do (myprintln "Num: " numStack "Opr: " oprStack "Infix: " infix)
        (if-not (first infix)
          (reduce ProcessNums
                  (first numStack)
                  ;; execute the whole num and opr stacks
                  (MakeRemoveAndProcessArray (rest numStack) oprStack))
          (let [sym (first (first infix))
                pri (second (first infix))]
            (if (= sym :number)
              ;; pri is number in this case
              (recur (conj numStack pri) oprStack (rest infix))
              (if (= sym :open-bracket)
                (recur numStack (conj oprStack (first infix)) (rest infix))
                (if (= sym :close-bracket)
                  ;; remove and process elements untill open brackets come
                  (let [nextOprStack (rest (drop-while
                                            ;; drop untill we find open bracket
                                            #(not (.equals :open-bracket (first %)))
                                            oprStack))
                        nextOprSize (count nextOprStack)
                        oprInitialSize (count oprStack)
                        removeAndProcessArray (MakeRemoveAndProcessArray
                                               (rest numStack)
                                               (take (- (- oprInitialSize nextOprSize) 1) oprStack))
                        ;; calculate the value
                        calculatedVal (reduce ProcessNums
                                              (first numStack)
                                              removeAndProcessArray)
                        ;; count the number of unary operations performed
                        noUnaryOpr (reduce #(+ %1 (if (= (first (second %2)) :unary-minus)
                                                    1
                                                    0))
                                           0 removeAndProcessArray)]

                    (recur (conj (drop
                                  ;; n+1 should be dropped
                                  ;; -1 for neglecting open bracket
                                  ;; + noUnaryOpr for number of unary operations
                                  (- (- oprInitialSize nextOprSize) noUnaryOpr)
                                  numStack)
                                 calculatedVal)
                           nextOprStack
                           (rest infix)))
                  ;; for all other than number open close bracket
                  ;; now we should remove and process untill we have
                  ;; somebody smaller than us.
                  (let [oprInitialSize (count oprStack)
                        ;; the next operator stack by removing operators untill someone with smaller
                        ;; precedence comes up.
                        nextOprStack (drop-while #(< pri (second %)) oprStack)
                        nextOprSize (count nextOprStack)
                        removeAndProcessArray (MakeRemoveAndProcessArray
                                               (rest numStack)
                                               (take (- oprInitialSize nextOprSize) oprStack))
                        calculatedVal (reduce ProcessNums
                                              (first numStack)
                                              removeAndProcessArray)
                        ;; count the number of unary operations performed
                        noUnaryOpr (reduce #(+ %1 (if (= (first (second %2)) :unary-minus)
                                                    1
                                                    0))
                                           0 removeAndProcessArray)]
                    ;; since ProcessNum would return the top value if no coputation happens.
                    ;; just pop push the same value
                    ;; but it can pass nil if there is nothing in numStack
                    (if calculatedVal
                      (let [nextNumStack (conj (drop (+ (- oprInitialSize nextOprSize) (- 1 noUnaryOpr)) numStack) calculatedVal)]
                        (recur nextNumStack (conj nextOprStack (first infix))
                               (rest infix)))
                      (recur numStack (conj nextOprStack (first infix))
                             (rest infix))))))))))))

(defn ComputeExpression [lst]
  (mod (InfixToPrefix (make-calulator-list lst)) ToMod))

(defn StartRun [FuncToCall inputParse outputParse]
  (let [lines (line-seq (java.io.BufferedReader. *in*))]
    (outputParse (FuncToCall (inputParse (first lines)))))
  )

(StartRun InfixToPrefix
       make-calulator-list
       (fn [x] (println (mod x ToMod))))

(defn BasicTests []
  (= 1717 (ComputeExpression " 22 * 79 - 21"))
  (= 12 (ComputeExpression " 4/2/2 + 8"))
  (= 999998605 (ComputeExpression "55+3-45*33-25"))
  (= 22 (ComputeExpression "11*(2/2)*2"))
  (= 11 (ComputeExpression "22*2/2*2"))
  (= 23 (ComputeExpression "+23"))
  (= 6 (ComputeExpression "(-(+(-2 * 3)))"))
  (= 0 (ComputeExpression "+0"))
  )

(BasicTests)
	;; ------- Euler Functions ---------------
	(set! unchecked-math true)

	(def ToMod (int (+ 1000000000 7)))

	(def toPrint false)

	(defn myprintln [& args]
	(if toPrint
	(apply println args)))

	(defn ^:static EulerPowNonMemoized ^long [^long x ^long p opr]
	;; calculates the x ^ p efficiently for large p where p+2 is a prime number.
	(let [startVal (if (= opr +) 0 1)] ;; ASSUMPTION only + * would be passed.
	(loop [num (long startVal) toPow p localX x]
	(if (= 0 toPow)
	;; just print out the results before returning num
	(do (myprintln " EulerPow : " num " for " x p)
	num)
	(let [squaredX (rem (opr localX localX) ToMod) ;; square successively
	halfToPow (bit-shift-right toPow 1)] ;; half the p successively
	(if (odd? toPow) ;; if toPow is odd then we should perform the opr on num with squared version.
	(recur (rem (opr num localX) ToMod)
	halfToPow
	squaredX)
	(recur num halfToPow squaredX)))))))

	;; (defn ^:static EulerPow ^long [^long x ^long y opr]
	;; ;; memoized version of EulerPow
	;; (memoize (EulerPowNonMemoized x y opr)))

	(def EulerPow (memoize EulerPowNonMemoized))

	;; + means multiplication and
	;; * means power in EulerPow
	;; (= 10 (EulerPow 2 5 +))
	;; (= (* 19 254) (EulerPow 19 254 +))
	;; (= 64 (EulerPow 2 6 *))
	;; (= 27 (EulerPow 3 3 *))

	;; since operands are put on the stack..
	;; subtaction and division have second parameter as first operator.
	;; does not make any thing different in add or mul.
	(defn ^:static ModAdd ^long [^long x ^long y]
	(rem (+ x y) ToMod))

	(defn ^:static ModSub ^long [^long x ^long y]
	(rem (- y x) ToMod))

	(defn ^:static ModMul ^long [^long x ^long y]
	(if (> 0 y)
	(rem (- (EulerPow x (- y) +)) ToMod)
	(rem (EulerPow x y +) ToMod)))

	;; (defn ModMul [^long x ^long y]
	;; (mod (* x y) ToMod))

	(defn ^:static ModDiv ^long [^long x ^long y]
	(ModMul y (EulerPow x (- ToMod 2) *)))

	;; (ModDiv 4 2)

	;; ------- splitting input functions ----------------

	(defn split-with-delim [d s]
	(clojure.string/split
	s (re-pattern (str "(?=" d
	")\|(?<=" d
	")"))))

	;; making priorities
	(def ^long plus-pri 2)
	(def ^long minus-pri 2)
	(def ^long mul-pri 4)
	(def ^long div-pri 4)
	(def ^long open-brac-pri 0) ;; open bracket would not remove anybody
	(def ^long close-brac-pri 6) ;; close bracket would keep removing untill encountered close bracket
	(def ^long unary-pri 10)

	(defn make-calulator-list [s]
	(->> s
	;; split into chars
	(split-with-delim #"[\/\+\-\*\(\) ]")
	;; remove empty and spaces
	(filter #(not (or (= "" %) (= " " %))))
	;; we can not remove unary +/- because ther can be -(((3)))
	;; convert the numbers into tokens.
	((fn [lst]
	(map (fn [x]
	(if (= x "+")
	[:plus-opr plus-pri ModAdd]
	(if (= x "-")
	[:minus-opr minus-pri ModSub]
	(if (= x "*")
	[:mul-opr mul-pri ModMul]
	(if (= x "/")
	[:div-opr div-pri ModDiv]
	(if (= x "(")
	[:open-bracket open-brac-pri]
	(if (= x ")")
	[:close-bracket close-brac-pri]
	;; this is just going to be a number not a vector
	[:number (long (Long. x))])
	))))))
	lst)))

	((fn [l]
	(let [fOpr (first (first l))]
	(if (= fOpr :plus-opr)
	(conj (rest l) [:unary-plus unary-pri ModAdd])
	(if (= fOpr :minus-opr)
	;; convert into unary minus sign
	(conj (rest l) [:unary-minus unary-pri ModSub])
	l)))))

	;; unary plus or minus
	;; ++++2
	;; ++--2
	;; *+-2
	;; *++2
	;; (+

	;; plus or minus
	;; 2+
	;; )+
	((fn [l]
	(loop [lst (rest l) lastToken (first l) returnLst (list lastToken)]
	(do (myprintln lst lastToken returnLst)
	(if-not (first lst)
	(reverse returnLst)
	(let [lastOpr (first lastToken)
	thisOpr (first (first lst))]
	(if (or (= thisOpr :minus-opr) (= thisOpr :plus-opr))
	(if-not (or (= lastOpr :close-bracket) (= lastOpr :number))
	;; this is unary plus or minus
	(if (= thisOpr :minus-opr) ;; if i thought i was minus opr
	(recur (rest lst) [:unary-minus unary-pri ModSub] (conj returnLst [:unary-minus unary-pri ModSub]))
	;; not adding + as it is of no use
	(recur (rest lst) [:unary-plus unary-pri ModAdd] returnLst))
	;; this is normal
	(recur (rest lst) (first lst) (conj returnLst (first lst))))
	;; this is normal
	(recur (rest lst) (first lst) (conj returnLst (first lst)))
	)))))
	))


	doall))

	(defn MakeRemoveAndProcessArray [F S]
	(loop [numStack F oprStack S m []]
	(let [fFirst (first numStack)
	sFirst (first oprStack)
	opr (first sFirst)]
	(if-not (and fFirst sFirst)
	(do (myprintln "\n** RemoveAnd Process Array : " m " For " S)
	(if sFirst
	(if (= opr :unary-minus)
	(conj m [0 sFirst])
	m)
	m))
	(if (= opr :unary-minus)
	(recur numStack (rest oprStack) (conj m [0 sFirst]))
	(recur (rest numStack) (rest oprStack) (conj m [fFirst sFirst])))))))

	(defn ProcessNums [val oprAndVal]
	;; val is last processed value of reduction
	;; oprAndVal contains next operation and right side value to process.
	;; oprAndVal is like [second-operand [operator-keyword operation-priority operation]
	(do (myprintln "ProcessNums " val oprAndVal)
	(if (and val (second oprAndVal))
	(let [opr (nth (second oprAndVal) 2)
	oprKeyword (first (second oprAndVal))
	secOperand (first oprAndVal)]
	(do (myprintln "ProcessNums" val secOperand opr oprKeyword)
	(if (= oprKeyword :unary-minus)
	(opr val 0)
	(opr val secOperand))))
	val)))

	;; Now only optimization remaining is that of using unary operators and not doing n^2 in above algorithm of AddCloseBracketImmediately
	(defn InfixToPrefix [infix*]
	(loop [numStack '() oprStack '() infix infix*]
	(do (myprintln "Num: " numStack "Opr: " oprStack "Infix: " infix)
	(if-not (first infix)
	(reduce ProcessNums
	(first numStack)
	;; execute the whole num and opr stacks
	(MakeRemoveAndProcessArray (rest numStack) oprStack))
	(let [sym (first (first infix))
	pri (second (first infix))]
	(if (= sym :number)
	;; pri is number in this case
	(recur (conj numStack pri) oprStack (rest infix))
	(if (= sym :open-bracket)
	(recur numStack (conj oprStack (first infix)) (rest infix))
	(if (= sym :close-bracket)
	;; remove and process elements untill open brackets come
	(let [nextOprStack (rest (drop-while
	;; drop untill we find open bracket
	#(not (.equals :open-bracket (first %)))
	oprStack))
	nextOprSize (count nextOprStack)
	oprInitialSize (count oprStack)
	removeAndProcessArray (MakeRemoveAndProcessArray
	(rest numStack)
	(take (- (- oprInitialSize nextOprSize) 1) oprStack))
	;; calculate the value
	calculatedVal (reduce ProcessNums
	(first numStack)
	removeAndProcessArray)
	;; count the number of unary operations performed
	noUnaryOpr (reduce #(+ %1 (if (= (first (second %2)) :unary-minus)
	1
	0))
	0 removeAndProcessArray)]

	(recur (conj (drop
	;; n+1 should be dropped
	;; -1 for neglecting open bracket
	;; + noUnaryOpr for number of unary operations
	(- (- oprInitialSize nextOprSize) noUnaryOpr)
	numStack)
	calculatedVal)
	nextOprStack
	(rest infix)))
	;; for all other than number open close bracket
	;; now we should remove and process untill we have
	;; somebody smaller than us.
	(let [oprInitialSize (count oprStack)
	;; the next operator stack by removing operators untill someone with smaller
	;; precedence comes up.
	nextOprStack (drop-while #(< pri (second %)) oprStack)
	nextOprSize (count nextOprStack)
	removeAndProcessArray (MakeRemoveAndProcessArray
	(rest numStack)
	(take (- oprInitialSize nextOprSize) oprStack))
	calculatedVal (reduce ProcessNums
	(first numStack)
	removeAndProcessArray)
	;; count the number of unary operations performed
	noUnaryOpr (reduce #(+ %1 (if (= (first (second %2)) :unary-minus)
	1
	0))
	0 removeAndProcessArray)]
	;; since ProcessNum would return the top value if no coputation happens.
	;; just pop push the same value
	;; but it can pass nil if there is nothing in numStack
	(if calculatedVal
	(let [nextNumStack (conj (drop (+ (- oprInitialSize nextOprSize) (- 1 noUnaryOpr)) numStack) calculatedVal)]
	(recur nextNumStack (conj nextOprStack (first infix))
	(rest infix)))
	(recur numStack (conj nextOprStack (first infix))
	(rest infix))))))))))))

	(defn ComputeExpression [lst]
	(mod (InfixToPrefix (make-calulator-list lst)) ToMod))

	(defn StartRun [FuncToCall inputParse outputParse]
	(let [lines (line-seq (java.io.BufferedReader. in))]
	(outputParse (FuncToCall (inputParse (first lines)))))
	)

	(StartRun InfixToPrefix
	make-calulator-list
	(fn [x] (println (mod x ToMod))))

	(defn BasicTests []
	(= 1717 (ComputeExpression " 22 * 79 - 21"))
	(= 12 (ComputeExpression " 4/2/2 + 8"))
	(= 999998605 (ComputeExpression "55+3-45*33-25"))
	(= 22 (ComputeExpression "11(2/2)2"))
	(= 11 (ComputeExpression "222/22"))
	(= 23 (ComputeExpression "+23"))
	(= 6 (ComputeExpression "(-(+(-2 * 3)))"))
	(= 0 (ComputeExpression "+0"))
	)

	(BasicTests)