;;; -*- mode: lisp; syntax: common-lisp -*-

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :hunchentoot)
  (require :cl-who))

(defpackage :web-232
    (:use :common-lisp :hunchentoot :cl-who)
    (:import-from :cl-user :defmemo)
    (:export :start :stop))

(in-package :web-232)

(defparameter *allowed-functions*
  '(1+ 1- + - / * exp expt sqrt log max min floor ceiling < > = <= >= /= if))

(defun index-page ()
  (with-html-output-to-string (*standard-output*)
    (:html (:head (:title "Project Euler Problem 232"))
           (:meta :http-equiv "Content-Type" :content "text/html;charset=utf-8")
           (:body (:h1 "Project Euler Problem 232 - Coin Flipping")
                  (:p "Two players share an unbiased coin and take it in turns to play `The Race'. On Player 1's turn, he tosses the coin once: if it comes up Heads, he scores one point; if it comes up Tails, he scores nothing. On Player 2's turn, she chooses a positive integer T and tosses the coin T times: if it comes up all Heads, she scores 2^(T-1) points; otherwise, she scores nothing. Player 1 goes first. The winner is the first to reach 100 or more points. (Description taken from the Project Euler website)")
                  (:p "Write a single sexp below that computes the optimal number of tosses, given that the deviations of the scores from the goal (100) are given in K1 and K2. Pressing the button will calculate the probability that the second player wins by this strategy.")
                  (:form :method "POST" :action "/probability"
                         (:textarea :rows 10 :cols 80 :name "algorithm")
                         (:br)
                         (:input :type "submit" :name "submit"
                                 :value "Calculate the probability"))
                  (:p (str (format nil "You can use the following functions: ~
                                        ~{~a~^, ~}." *allowed-functions*)))
                  (:h2 "Some examples")
                  (:pre ";;; 0.60032004
 (1+ (floor (log k2 2)))")
                  (:pre ";;; 0.79201570
 (1+ (ceiling (log (max (- k2 k1) 1) 2)))")
                  (:pre ";;; 0.81928601
 (if (<= k2 k1)
     1
     (+ 2 (floor (log (- k2 k1 -1) 2))))")))))

(defun decide-tosses (k1 k2)
  (declare (ignore k1 k2))
  1)

(defmemo player1 (k1 k2)
  (if (<= k2 0)
      1.0d0
      (let ((a (decide-tosses k1 k2)))
        (/ (+ (/ (player2 (1- k1) k2) 2)
              (/ (player1 k1 (- k2 (expt 2 (1- a)))) (expt 2 (1+ a))))
           (* 1/2 (1+ (expt 2 (- a))))))))

(defmemo player2 (k1 k2)
  (if (<= k1 0)
      0.0d0
      (let ((a (decide-tosses k1 k2)))
        (/ (+ (* (player1 k1 (- k2 (expt 2 (1- a)))) (expt 2 (- a)))
              (* (player2 (1- k1) k2) (* 1/2 (- 1 (expt 2 (- a))))))
           (* 1/2 (1+ (expt 2 (- a))))))))

(defun illegal-functions (sexp)
  (labels ((rec (lst)
             (cond ((atom lst) 'nil)
                   ((member (first lst) *allowed-functions*)
                    (mapcan #'rec (rest lst)))
                   (t (append (list (first lst)) (mapcan #'rec (rest lst)))))))
    (rec sexp)))

(defun check-and-compute (str)
  (handler-case
      (let* ((*package* (find-package :web-232)) ; for SEXP to be read in the
             (sexp (read-from-string str))       ; appropriate package
             (illegal (illegal-functions sexp)))
        (if (null illegal)
            (progn
              (eval `(defun decide-tosses (k1 k2) ,sexp))
              (player1-forget) (player2-forget)
              (format nil "The probability is ~f." (player1 100 100)))
            (format nil "The following functions are not allowed: ~{~a~^, ~}."
                    illegal)))
    (parse-error (pe) (format nil "Malformed expression: ~a." pe))
    (error (e) (format nil "ERROR: ~a" e))))

(defun calculate-probability ()
  (let ((algorithm (cdr (assoc "algorithm" (post-parameters) :test #'string=))))
    (with-html-output-to-string (*standard-output*)
      (:html (:head (:title "Probability")
                    (:script :type "text/javascript"
                             "function prevpage() { window.history.back() }"))
             (:meta :http-equiv "Content-Type"
                    :content "text/html;charset=utf-8")
             (:body (:h2 (str (check-and-compute algorithm)))
                    (:input :type "button"
                            :value "Go back" :onclick "prevpage()"))))))

(defvar *web-232-server*)
(defun start (&optional (port 2001))
  (setf *web-232-server* (start-server :port port))
  (setf *dispatch-table*
        (list (create-regex-dispatcher "^/$" #'index-page)
              (create-regex-dispatcher "^/probability$"
                                       #'calculate-probability))))
(defun stop ()
  (stop-server *web-232-server*))

(start)