;(module metadice
;        mzscheme
(begin
(require (lib "pregexp.ss"))
(require (lib "list.ss"))
(require (rename (lib "1/list.ss" "srfi") every every))
(require (rename (lib "1/list.ss" "srfi") take-while take-while))
(require (rename (lib "1/list.ss" "srfi") drop-while drop-while))
(require (rename (lib "1/list.ss" "srfi") find find))

; This is a porting of the syntax of bananabot, but not the implementation. This implementation has several goals:
; * Learn Scheme
; * Write a completely declarative, useful program
; * Reimplement all this logic the way it should have been done in the first place, without stupid regexp hacks.




;;;;;;;;;; Dice implementation ;;;;;;;;;;

; The basic "roll a die" procedure
(define (die x)
  (+ 1 (random x)))

; As above, but exploding on max roll
(define (wild-die x)
  (let ((roll (+ 1 (random x))))
    (if (not (= roll x))
        roll
        (+ roll (wild-die x)))))

; Roll more than one die. 100000 seems to be the upper limit of x; that takes 2-4 seconds.
(define (dice x y)
  (case x
    ((0) 0)
    ((1) (die y))
    (else (+ (die y) (dice (- x 1) y)))))

; A common type of roll in some systems - one die wild, the others normal.
(define (open-dice x y)
  (+ (wild-die y) (dice (- x 1) y)))




;;;;;;;;;; Parsing implementation ;;;;;;;;;;

(define operators (list "\\+" "-" "\\(" "\\)" "d" "o" "\\*" "/" "\\^" "\\\\" "%" "#" ","))
(define literals (list "\\d+"))

; this section is a program really I mean it does lots of calculations and stuff but TECHNICALLY these are constants ;_;
; Seriously, they are at least only calculated once, rather than every line of input. That's something.
; however the way the frontend currently works it is useless
(define valid-tokens (append operators literals))
(define re-validator (pregexp (foldr
                               (lambda (x y)
                                 (string-append x "|" y))
                               (car valid-tokens)
                               (cdr valid-tokens))))
(define re-literal-validator (pregexp (foldr
                               (lambda (x y)
                                 (string-append x "|" y))
                               (car literals)
                               (cdr literals))))

; Does this really need to be a seperate procedure? Only to keep core logic out of the main loop.
(define pregexp-match*
   (lambda (regex string)
     (letrec
         ((pregexp-match*
           (lambda (regex string pos)
             (let ((endpos (pregexp-match-positions regex string pos)))
               (if (eq? endpos #f) '()
                   (cons (pregexp-match regex string pos)
                         (pregexp-match* regex string (cdar endpos))))))))
       (pregexp-match* regex string 0))))
(define (tokenize s)
  (map car (pregexp-match* re-validator s)))

; ugh this works in such a stupid way because and is a stupid special form instead of, I don't know, A PROCEDURE
(define (validate l)
  (every (lambda (x) (car (pregexp-match re-validator x)))
         l))

; Give this function a constant or a special case - something to hand to the dice engine
; Die handing should be in the parser, because 3d6 is a valid number.
; Scheme thinks it's 3.000000 :( It's even an integer!
(define (handle-literal x)
  (cond
    ((list? x) (map handle-literal x))
    ((pregexp-match "\\d+d\\d+" x)
     (let* ((ns (pregexp-split "d" x))
            (n (string->number (car ns)))
            (s (string->number (cadr ns))))
       (dice n s)))
    ((number? (string->number x)) (string->number x))
    (else "error: unrecognised literal")))

; Multiplex rolls - n is number
(define (multi n t)
  (case n
    ((0) '())
    ((1) (list t))
    (else (cons t
                (multi (- n 1) t)))))
(define (rmulti t n) (multi n t))



; parsing logic prototype:
; ARGUMENTS a list of valid tokens
; RETURN the result of calculation
; so we have a huge case statement (no Haskell pattern-matching :() and recurse
(define maybe-map-3 (lambda (f x y)
                    (if (list? y)
                        (map (lambda (y) (f x y))
                             y)
                        (if (list? x)
                            (map (lambda (x) (f x y))
                                 x)
                            (f x y)))))

(define maybe-map-2 (lambda (f x)
                      (if (list? x)
                          (maybe-map-3 maybe-map-2 f x)
                          (f x))))

(define (str=? s x)
        (if (list? s)
            (every (lambda (s) (equal? x #t))
                   (map (lambda (s) (string=? s x))
                        s))
            (string=? s x)))

(define (parse l)
  (let* ((operate (lambda (x f)
                  (maybe-map-3 f
                             (parse (take-while
                                     (lambda (s) (not (str=? s x)))
                                     l))
                             (parse (cdr (drop-while
                                          (lambda (s) (not (str=? s x)))
                                          l))))))
         (check (lambda (x)
                (find (lambda (s) (str=? s x))
                      l)))
         (replace-deepest-parantheses (lambda (xs)
                                        (let* ((rpre (reverse (take-while
                                                     (lambda (s) (not (str=? s ")")))
                                                     xs)))
                                               (post (cdr (drop-while
                                                           (lambda (s) (not (str=? s ")")))
                                                           xs)))
                                               (mid (reverse (take-while
                                                              (lambda (s) (not (str=? s "(")))
                                                              rpre)))
                                               (pre (reverse (cdr (drop-while
                                                              (lambda (s) (not (str=? s "(")))
                                                              rpre)))))
                                          (append pre (cons (maybe-map-2 number->string
                                                                        (parse mid))
                                                            post))))))
     (cond ; Parenthesis insertion
           ((check "(") (parse (replace-deepest-parantheses l)))
           ; Low precendence - O(1) mathematics
           ((check "+") (operate "+" +))
           ((check "-") (operate "-" -))
           ; Medium precedence
           ((check "*") (operate "*" *))
           ((check "^") (operate "^" expt))
           ((check "/") (operate "/" /))
           ((check "\\") (operate "\\" quotient))
           ((check "%") (operate "%" remainder))
           ; High precedence - dice
           ((check "d") (operate "d" dice))
           ((check "o") (operate "o" open-dice))
           ; Multiplexing
           ((check "#") (operate "#" multi))
           ((check ",") (operate "," rmulti))
           ; Literals
           (else (handle-literal (car l))))))




;;;;;;;;;; Main ;;;;;;;;;;
(if (> (vector-length argv) 0)
    (let* ((raw-input (apply string-append (vector->list argv)))
           (tokenized-input (tokenize raw-input)))
      (display
       (if (validate tokenized-input)
           (parse tokenized-input)
           "error: incorrect syntax"))
      (newline))
    (letrec
        ((raw-input "")
         (tokenized-input ())
         (mainloop (lambda ()
                     (set! raw-input (read-line))
                     (if (eof-object? raw-input) ()
                         (begin
                           (set! tokenized-input (tokenize raw-input))
                           (display
                            (if (validate tokenized-input)
                                (parse tokenized-input)
                                "error: incorrect syntax"))
                           (newline)
                           (mainloop))))))
      (mainloop))))