Shunting Yard algo implementation for programming contest.

shunting-yard-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 (vec (list lastToken))]
            (do (myprintln lst lastToken returnLst)
                (if-not (first lst)
                  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 []]
    ;; using vector for m as it may be both efficient as well as
    ;; we need to add things in the end and we do not want to keep doing 
    ;; reverse again.
    (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)
              (opr val secOperand)
              ;; (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))))