From f6053c53a6aec44634d1e3f2c5067621e2f1b02a Mon Sep 17 00:00:00 2001
From: John Fremlin <john@fremlin.org>
Date: Sun, 3 Jun 2012 04:16:56 +0100
Subject: [PATCH] redesign game UI to make it slightly less atrocious

---
 src/blackjack/blackjack.lisp |   2 +-
 src/game/coins.lisp          |   2 +-
 src/game/framework.lisp      |   9 +-
 src/game/web-messages.lisp   |  17 ++-
 src/game/web.lisp            | 282 +++++++++++++++++------------------
 src/packages.lisp            |   2 +
 src/webapp/actions.lisp      |  15 +-
 src/webapp/frame.lisp        |   2 +
 src/webapp/js-library.lisp   |   9 +-
 src/webapp/page.lisp         |   1 -
 10 files changed, 169 insertions(+), 172 deletions(-)

diff --git a/src/blackjack/blackjack.lisp b/src/blackjack/blackjack.lisp
index 7eda3e7..c0a150b 100644
--- a/src/blackjack/blackjack.lisp
+++ b/src/blackjack/blackjack.lisp
@@ -124,7 +124,7 @@
 		((my blackjack)
 		 (<p :class "blackjack" "Blackjack!"))))))
 
-(my-defun blackjack-player 'object-to-ml ()
+(my-defun blackjack-player 'player-full-state-to-ml ()
   (<div :class "blackjack-player"
 	(call-next-method)
 	(loop for h in (my hands)
diff --git a/src/game/coins.lisp b/src/game/coins.lisp
index f1667e5..f5d409e 100644
--- a/src/game/coins.lisp
+++ b/src/game/coins.lisp
@@ -12,7 +12,7 @@
                 do
                 (setf (player-controller-var p 'coins) (its coins p))))
 
-(my-defun coin-game-player 'object-to-ml ()
+(my-defun coin-game-player 'player-full-state-to-ml ()
   (<div :class "coin-game-player"
         (call-next-method)
         (let ((coins (or (my coins) (my 'player-controller-var 'coins))))
diff --git a/src/game/framework.lisp b/src/game/framework.lisp
index 8d0e773..55d8cf3 100644
--- a/src/game/framework.lisp
+++ b/src/game/framework.lisp
@@ -28,7 +28,7 @@
   (random-elt (choices-list choices)))
 
 (my-defun game finished (&rest args)
-  (setf (my game-over) t)
+  (setf (my game-over) (list* :game-over args))
   (apply 'game-announce me :game-over args)
   (values))
 
@@ -40,6 +40,11 @@
 (my-defun player announce (message &rest args)
   (apply 'game-announce (my game) message args))
 
+(defgeneric player-full-state-to-ml (player))
+
+(my-defun player full-state-to-ml ()
+  (object-to-ml me))
+
 (my-defun game listeners ()
   (append (mapcar 'player-controller (my players)) (my other-listeners)))
 
@@ -173,4 +178,4 @@
 (defmethod (setf player-controller-var) (new-value (player player) var)
   (setf (player-controller-var (player-controller player) var) new-value))
 (defmethod player-controller-name-to-ml ((player player))
-  (player-controller-name-to-ml (player-controller player)))
\ No newline at end of file
+  (player-controller-name-to-ml (player-controller player)))
diff --git a/src/game/web-messages.lisp b/src/game/web-messages.lisp
index 92a7379..0d1a645 100644
--- a/src/game/web-messages.lisp
+++ b/src/game/web-messages.lisp
@@ -1,21 +1,24 @@
 (in-package #:tpd2.game)
 
 (defmacro def-web-state-message (message args &body body)
-  `(my-defun web-state 'inform (game-state (message (eql ,message)) &key ,@args &allow-other-keys)
-     (declare (ignorable game-state))
-     (macrolet ((a (&rest args)
-                  `(my add-announcement (<p :class "game-message" ,@args))))
-       ,@body)))
+  `(progn
+     (defmethod message-to-ml ((message (eql ,message)) &key ,@args &allow-other-keys)
+       (declare (ignorable game-state))
+       (with-ml-output ,@body))
+     (my-defun web-state 'inform (game-state (message (eql ,message)) &key ,@args &allow-other-keys)
+       (declare (ignorable game-state))
+       (my add-announcement (<p :class "game-message" ,@body)))))
 
 (macrolet ((messages (&body body)
              `(progn
                 ,@(loop for (keyword args . ml) in body
                         collect `(def-web-state-message ,keyword ,args
-                                   (a ,@ml))))))
+                                   ,@ml)))))
 
   (messages
    (:talk (sender text)
           (<span :class "game-talk-message" sender ": " (<q text)))
+   (:shuffle () "The deck has been shuffled.")
    (:new-player (player)
                 player " has joined the game.")
    (:resigned (player)
@@ -57,7 +60,7 @@
                      (t
                       (when result
                         (with-ml-output
-                            (friendly-string result) ".")
+                            (friendly-string result) ". ")
                         "Game over."))))
    (:demand (player amount)
             player " demanded " amount ".")
diff --git a/src/game/web.lisp b/src/game/web.lisp
index 4eedf44..3207ab3 100644
--- a/src/game/web.lisp
+++ b/src/game/web.lisp
@@ -15,6 +15,8 @@
   timed-out
   (timeout (make-timeout)))
 
+(defgeneric message-to-ml (message &rest args))
+
 (defun make-web-state-from-frame ()
   (let ((frame (webapp-frame)))
     (check-type frame frame)
@@ -144,13 +146,7 @@
                            (let-current-values (c)
                              (with-ml-output " "
                                              (html-action-link (friendly-string c)
-                                               (my queue-choice c)))))
-
-                     (html-action-form
-                         ""
-                         (choice)
-                       (my queue-choice (read-safely-from-string choice))
-                       (values))))))))
+                                               (my queue-choice c)))))))))))
 
 
 
@@ -165,8 +161,8 @@
 
 
 (my-defun game 'object-to-ml :around ()
-          (if (my game-over)
-              (<h2 "Game over." (my play-again-ml) "?")
+          (aif (my game-over)
+              (<h2 (apply 'message-to-ml it) " " (my play-again-ml) "?")
               (call-next-method)))
 
 (defun current-web-controller (controller)
@@ -179,7 +175,9 @@
     (my notify)))
 
 (my-defun web-state 'player-controller-name-to-ml ()
-  (<span :class "username" (frame-username (my frame))))
+  (if (and (webapp-frame-available-p) (eq (my frame) (webapp-frame)))
+      (with-ml-output "You")
+      (<span :class "username" (frame-username (my frame)))))
 
 (my-defun web-state 'player-controller-var ( var)
   (frame-var (my frame) var))
@@ -187,26 +185,6 @@
 (my-defun web-state (setf 'player-controller-var) (new-value var)
   (setf (frame-var (my frame) var) new-value))
 
-(defgeneric game-title-ml (game)
-  (:method (game)
-    (<h2 :class "game-title"
-         (game-name game))))
-
-(my-defun web-state 'object-to-ml ()
-  (assert (my game-state) () "No game started; please use game-new-state")
-  (<div :class "game-state"
-        (<div :class "game-header"
-              (game-title-ml (my game-state)))
-
-        (call-next-method)
-
-        (<div :class "talk"
-              (html-action-form "Talk "
-                  ((text nil :reset ""))
-                (without-ml-output
-                  (my timeout-reset)
-                  (game-talk (my game-state) me text))))))
-
 (my-defun game play-again-ml ()
   (html-replace-link "Play again"
     (web-game-start (my generator))))
@@ -215,34 +193,40 @@
   (game-play-again-ml (my game-state)))
 
 (my-defun web-state 'simple-channel-body-ml ()
+  (assert (my game-state) () "No game started; please use game-new-state")
   (<div :class "game-state"
-        (<div :class "game-state-body"
-              (<p :class "close-game"
-                  (cond ((game-game-over (my game-state))
-                         (my play-again-ml))
-                        (t
-                         (html-action-link "Resign"
-                           (my resign))))))
-
-        (<div :class "messages-and-talk"
-              (<div :class tpd2.webapp:+html-class-scroll-to-bottom+
-                    (output-object-to-ml (my announcements))))
-
-        (cond
+	(cond
           ((my timed-out)
-           (<p (load-time-value (format nil "Timed out; sorry, you took longer than ~R second~:P to respond."
-                                        *web-state-move-timeout*))
+           (<p (load-time-value 
+		(format nil "Timed out; sorry, you took longer than ~R second~:P to respond."
+			*web-state-move-timeout*))
+	       " "
                (my play-again-ml) "?"))
           ((my resigned)
-           (<p "Resigned." (my play-again-ml)))
+           (<p "Resigned. " (my play-again-ml) "?"))
           (t
            (output-object-to-ml (my game-state))
 
            (when (my waiting-for-input)
              (<div :class "moves"
-                   (loop for m in (my waiting-for-input)
-                         do
-                         (output-object-to-ml m))))))))
+                   (loop for m in (my waiting-for-input) do
+                         (output-object-to-ml m))))))
+
+	(html-change-username-form)
+        (<div :class "talk"
+              (html-action-form "Talk "
+                  ((text nil :reset ""))
+                (without-ml-output
+                  (my timeout-reset)
+                  (game-talk (my game-state) me text))))
+	(cond ((not (game-game-over (my game-state)))
+	       (<p :class "close-game"
+		   (html-action-link "Resign"
+		     (my resign)))))
+
+        (<div :class "messages-and-talk"
+              (<div :class tpd2.webapp:+html-class-scroll-to-bottom+
+                    (output-object-to-ml (my announcements))))))
 
 (my-defun player state-to-ml ()
   (<div :class "player"
@@ -254,94 +238,96 @@
   (player-controller-name-to-ml (my controller)))
 
 (defun css ()
-  (css-html-style
-    ((".inherit" <input <a)
-     :text-decoration "inherit" :color "inherit" :background-color "inherit" :font-size "inherit" :font-weight "inherit"
-     :font-family "inherit"
-     :border "none" :padding "0 0 0 0" :margin "0 0 0 0")
-    (<body :font-family "georgia, serif" :word-spacing "0.075em" :letter-spacing "0.025em" :margin-left "5%" :margin-right "5%"
-           :background-color "white")
-    ((<h1 <h2 <h3 <h4 <h5 <h6) :letter-spacing "0.05em" :font-weight "normal" :margin "0 0 0 0" :padding "0 0 0 0")
-    ((<span <div <h1 <h2 <h3 <h4 <h5 <h6 <p <a <input) :direction "ltr" :unicode-bidi "bidi-override")
-    ("input[type=text]"
-     :display "inline"
-     :border-bottom "thin dashed black"
-     :font-style "italic" )
-    (".frame"
-     :color "rgb(188,188,188)")
-    (".game-message" :font-style "italic")
-    (".change-name" :font-size "75%" :text-align "right")
-    (".messages-and-talk"
-     :margin-top "2em"
-     :margin-left "1em"
-     :text-align "left")
-    (".robot" :font-style "italic")
-    ('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+)
-      :overflow "auto"
-      :padding-right "0.5em"
-      :height "20em" )
-    (".play-game-description,.about"
-     :padding-left "3em"
-     :padding-right "3em")
-
-    (".game-header"  :float "left")
-    (".close-game:before" :content "\"+ \"")
-    (".players"
-     :float "right"
-     :margin-top "2em"
-     )
-    (".game-header + .messages-and-talk + DIV"
-     :clear "both")
-    (".players > DIV"
-     :padding "0.4em 0.4em 0.4em 0.4em"
-     :float "left"
-     :border-top "2px solid black"
-     )
-    ("h1.mopoko" :font-size "4em" :text-align "right" :color "rgb(188,188,188)" :margin-bottom "0.333em")
-    (<h2 :font-size "2.5em")
-    (".webapp-section > ul > li" :padding-bottom "1em")
-    (".webapp-section > ul > li a.-replace-link-" :font-size "2em")
-    (".separate"
-     :height "4em"
-     :border-right "2px solid black")
-    (".talk input[type=\"text\"]" :width "60%")
-    (("input[type=submit]" <a "[onclick]")
-     :display "inline"
-     :text-decoration "none")
-    (".HEARTS, .DIAMONDS" :color "red")
-    (".HEARTS, .DIAMONDS, .CLUBS, .SPADES" :font-size "4em")
-    (".close-game" :text-align "right")
-    ("[onclick],a,input[type=submit]"
-     :background-color "rgb(228,228,228)"
-     :cursor "pointer")
-    ("#-async-status-"
-     :position "fixed"
-     :bottom "0em"
-     :padding "0.2em 0.2em 0.2em 0.2em"
-     :margin "0 0 0 0"
-     :right "0em"
-     :text-align "right"
-     :background-color "white"
-     :font-size "70%"
-     :x-border-radius "0.3em"
-     :border "thin solid #cccccc";
-     :z-index 2)
-
-    ))
+  (let ((gray "rgb(188,188,188)"))
+   (css-html-style
+     ((".inherit" <input <a)
+      :text-decoration "inherit" :color "inherit" :background-color "inherit" :font-size "inherit" :font-weight "inherit"
+      :font-family "inherit"
+      :border "none" :padding "0 0 0 0" :margin "0 0 0 0")
+     (<body :font-family "georgia, serif" :word-spacing "0.075em" :letter-spacing "0.025em" :margin-left "5%" :margin-right "5%"
+	    :background-color "white")
+     ((<h1 <h2 <h3 <h4 <h5 <h6) :letter-spacing "0.05em" :font-weight "normal" :margin "0 0 0 0" :padding "0 0 0 0")
+     ((<span <div <h1 <h2 <h3 <h4 <h5 <h6 <p <a <input) :direction "ltr" :unicode-bidi "bidi-override")
+     ("input[type=text]"
+      :display "inline"
+      :border-bottom "thin dashed black"
+      :font-style "italic" )
+     (".frame"
+      :color gray)
+     (".game-message" :font-style "italic")
+     (".change-name" :font-size "75%" :text-align "right")
+     (".messages-and-talk"
+      :margin-top "2em"
+      :margin-left "1em"
+      :text-align "left")
+     (".robot" :font-style "italic")
+     ('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+)
+       :overflow "auto"
+       :padding-right "0.5em"
+       :height "20em" )
+     (".play-game-description,.about"
+      :padding-left "3em"
+      :padding-right "3em")
+
+     (".game-header"  :float "left")
+     (".close-game:after" :content "\" - \"")
+     (".players"
+      :float "right"
+      :margin-top "2em"
+      )
+     (".game-header + .messages-and-talk + DIV"
+      :clear "both")
+     (".players > DIV"
+      :padding "0.4em 0.4em 0.4em 0.4em"
+      :float "left"
+      :border-top "2px solid black"
+      )
+     ("h1.mopoko" :font-size "4em" :text-align "left" :color "black" :margin-bottom "0.333em")
+     ("h1.mopoko a" :color gray)
+     (<h2 :font-size "2.5em")
+     (".webapp-section > ul > li" :padding-bottom "1em")
+     (".webapp-section > ul > li a.-replace-link-" :font-size "2em")
+     (".separate"
+      :height "4em"
+      :border-right "2px solid black")
+     (".talk input[type=\"text\"]" :width "60%")
+     (("input[type=submit]" <a "[onclick]")
+      :display "inline"
+      :text-decoration "none")
+     (".HEARTS, .DIAMONDS" :color "red")
+     (".HEARTS, .DIAMONDS, .CLUBS, .SPADES" :font-size "4em")
+     (".close-game" :text-align "right")
+     ("[onclick],a,input[type=submit]"
+      :background-color "rgb(228,228,228)"
+      :cursor "pointer")
+     ("#-async-status-"
+      :position "fixed"
+      :bottom "0em"
+      :padding "0.2em 0.2em 0.2em 0.2em"
+      :margin "0 0 0 0"
+      :right "0em"
+      :text-align "right"
+      :background-color "white"
+      :font-size "70%"
+      :x-border-radius "0.3em"
+      :border "thin solid #cccccc"	;
+      :z-index 2)
+
+     )))
 
 (defsite *site*
     :page-body-start (lambda(title)
-                       (declare (ignore title))
-                               `(<div :class "header"
-                                      (<h1 :class "mopoko"
-                                           (<A :href (page-link "/")
-                                               :class "inherit"
-                                               "mopoko " " prerelease" ))
-                                      (<h4 :id ,tpd2.webapp:+html-id-async-status+ )
-                                      (output-object-to-ml (webapp-frame))))
+		       `(<div :class "header"
+			      (<h1 :class "mopoko"
+				   (output-raw-ml ,title) " " 
+				   (<A :href (page-link "/")
+				       :class "inherit mopoko"
+				       "mopoko"))
+			      (<h4 :id ,tpd2.webapp:+html-id-async-status+ )
+			      (output-object-to-ml (webapp-frame))))
     :page-head (lambda(title)
                  `(with-ml-output
-                    (<title "mopoko.com " (output-raw-ml ,title))
+                    (<title "mopoko " (output-raw-ml ,title))
                     (css)
                     (webapp-default-page-head-contents)))
     :page-body-footer
@@ -366,25 +352,25 @@
   (defun web-game-start (game-generator)
     (let ((c (make-web-state-from-frame)))
       (game-generator-join-or-start game-generator c)
-      (webapp ()
-        (webapp-display c))))
+      (webapp ((string-downcase (force-string (game-name (web-state-game-state c)))))
+	  (webapp-display c))))
 
   (defpage "/" ()
     (webapp ""
-      (webapp-select-one ""
-                         (loop for g being the hash-values of *games*
-                               when (game-generator-advertised g)
-                               collect g)
-                         :display (lambda(g) (output-raw-ml
-                                         "Play " (game-generator-name g)))
-                         :describe (lambda (g)
-                                     (let ((d (game-generator-description g)))
-                                       (when d
-                                         (<div :class "play-game-description"
-                                          (output-raw-ml d)))))
-                         :replace
-                         (lambda(g)
-                           (web-game-start g)))
+      (webapp-select-one 
+       ""
+       (loop for g being the hash-values of *games*
+	     when (game-generator-advertised g)
+	     collect g)
+       :display (lambda(g) (output-raw-ml
+		       "Play " (game-generator-name g)))
+       :describe (lambda (g)
+		   (let ((d (game-generator-description g)))
+		     (when d
+		       (<div :class "play-game-description"
+			     (output-raw-ml d)))))
+       :replace (lambda(g)
+		  (web-game-start g)))
 
       (html-collapser (<h3 "About mopoko.com")
         (<div :class "about"
diff --git a/src/packages.lisp b/src/packages.lisp
index 79e078c..63ab128 100644
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -311,6 +311,7 @@
 
    #:page-link
    #:webapp-frame
+   #:webapp-frame-available-p
    #:*default-site*
    #:*webapp-frame*
    #:webapp-frame-var
@@ -318,6 +319,7 @@
    #:frame
    #:frame-var
    #:frame-username
+   #:html-change-username-form
    #:frame-messages
    #:frame-trace-info
    #:frame-destroy-hooks
diff --git a/src/webapp/actions.lisp b/src/webapp/actions.lisp
index bb43ad6..d3ef2f6 100644
--- a/src/webapp/actions.lisp
+++ b/src/webapp/actions.lisp
@@ -99,7 +99,7 @@
          (<p
           ,title
           ,@body-ml
-          (<input :class "plain-submit" :type :submit :value "↵"))))))
+	  (<input :class "plain-submit" :type :submit :value "↵"))))))
 
 (defun find-action (id)
   (when id
@@ -127,11 +127,10 @@
   (defpage-lambda url
       #'action-respond-body :defaulting-lambda-list (.id. .javascript.)))
 
+(my-defun frame change-username-form ()
+  (html-action-form "Your name " ((new-name (my username)))
+    (my change-username new-name)
+    (values)))
 
-(my-defun frame 'simple-channel-body-ml ()
-  (<div :class "frame"
-        (<div :class "change-name"
-              (html-action-form "Your name " ((new-name (my username)))
-                (my change-username new-name)
-                (values)))))
-
+(defmacro html-change-username-form ()
+  `(with-ml-output (frame-change-username-form (webapp-frame))))
\ No newline at end of file
diff --git a/src/webapp/frame.lisp b/src/webapp/frame.lisp
index 9f38902..3841b44 100644
--- a/src/webapp/frame.lisp
+++ b/src/webapp/frame.lisp
@@ -61,3 +61,5 @@
   (setf (my username) new-name)
   (my notify)
   new-name)
+
+(my-defun frame 'simple-channel-body-ml ())
\ No newline at end of file
diff --git a/src/webapp/js-library.lisp b/src/webapp/js-library.lisp
index 3d38f33..1e0723d 100644
--- a/src/webapp/js-library.lisp
+++ b/src/webapp/js-library.lisp
@@ -18,10 +18,10 @@
     (cond ((not object-paths)
            slot)
           (t
-           `(getprop
+           `(ps:getprop
              ,(if (rest object-paths)
-                 `(~ ,@object-paths)
-                 (first object-paths))
+		  `(~ ,@object-paths)
+		  (first object-paths))
              ',slot)))))
 
 (ps:defpsmacro ignore-errors (&body body)
@@ -227,7 +227,8 @@
 
     (defun async-submit-link-href (link)
       (when (async-submit-link link)
-        (setf (~ window location) link)))
+        (setf (~ window location) link))
+      t)
 
     (defun channel (name counter)
       (setf (aref *channels* name) counter))
diff --git a/src/webapp/page.lisp b/src/webapp/page.lisp
index 1884abe..fbd712b 100644
--- a/src/webapp/page.lisp
+++ b/src/webapp/page.lisp
@@ -90,7 +90,6 @@
 (defun-speedy random-web-safe-char ()
   (aref +web-safe-chars+ (random (length +web-safe-chars+))))
 
-
 (defun random-web-sparse-key (length)
   (let ((bv (make-byte-vector length)))
     (loop for i from 0 below length