game of truc working again but with messed up css

vii · Jan 3, 2009 · 458dca0 · 458dca0
1 parent 50f082b
commit 458dca0
Show file tree

Hide file tree

Showing 9 changed files with 66 additions and 92 deletions.
diff --git a/src/blog/entry.lisp b/src/blog/entry.lisp
@@ -93,19 +93,18 @@
 					 ("${static-base}"  (blog-static-base-url (my blog)))))))
 
 (defun parse-time (str)
-  (match-bind ( (- #\0 #\9) 
-	       (year (and ((string) a0 (month
-
-  (flet ((parse-number (str)
-	   (or (and str (parse-integer str)) 0)))
-    (regex-bind ((#'parse-number year) 
-		 (#'parse-number month) 
-		 (#'parse-number date) 
-		 (#'parse-number hour)  
-		 (#'parse-number minute) 
-		 (#'parse-number second))
-		("(\\d\\d\\d\\d)\\D*(\\d\\d?)\\D*(\\d\\d?)\\D*(?:(\\d\\d?)\\D*(\\d\\d?)\\D*(?:(\\d\\d?))?)?" str)
-		(apply 'encode-universal-time (mapcar (lambda(x) (or x 0)) (list second minute hour date month year))))))
+  (match-bind 
+   (macrolet ((int (name &optional (len 2))
+		 `(progn t (,name (unsigned-byte :max-len ,len) 0))))
+      (int year 4)
+      (int month)
+      (int day)
+      (:? 
+       (int hour)
+       (int minute)
+       (:? (int second))))
+      str
+    (encode-universal-time second minute hour day month year)))
 
 (defun read-in-blog-entry (name)
   (let ((blog-entry (make-blog-entry :name name)))

diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -137,10 +137,10 @@
 
 		   friendly-move-type
 		   "? "
-		    
-		   (output-raw-ml (html-action-link "Yes" (my queue-choice t) (values)))
+
+		   (html-action-link "Yes" (my queue-choice t) (values))
 		   " "
-		   (output-raw-ml (html-action-link "No" (my queue-choice nil) (values)))))
+		   (html-action-link "No" (my queue-choice nil) (values))))
 		((eql :select-card (my move-type))
 		 (<p friendly-move-type "."))
 		(t
@@ -150,13 +150,12 @@
 					    (apply 'max (choices-list (my choices))) ". "))
 			   (t
 			    (with-ml-output (format nil " ~{~A ~}" (my args)) " from " (format nil "~A" (my choices) ))))
-
-		     (output-raw-ml 
-		      (html-action-form 		     
-			  ""
-			  ((choice (first (choices-list (my choices)))))
-			(my queue-choice (read-safely-from-string choice))
-			(values)))))))))
+
+		     (html-action-form 		     
+			 ""
+			 ((choice (first (choices-list (my choices)))))
+		       (my queue-choice (read-safely-from-string choice))
+		       (values))))))))
 
 
 
@@ -167,7 +166,7 @@
 	      unless once do (<div :class "separate")
 	      do (output-object-to-ml p))
 	(<div :style (css-attrib :clear "both" :float "none" :border "none"))))
-	  
+
 
 (my-defun game 'object-to-ml :around ()
 	  (if (my game-over)
@@ -191,40 +190,40 @@
 	(<div :class "game-header"
 	      (<h2 :class "game-title"
 		   (string-capitalize (force-string (game-name (my game-state))))))
-
-
+
 	(call-next-method)
-
+	
 	(<div :class "talk"
 	      (html-action-form "Talk " 
 		  (text)
 		(without-ml-output
 		  (game-talk (my game-state) me text))))))
 
 (my-defun web-state 'simple-channel-body-ml ()
-  (<div :class "game-state-body" 
-	(<p :class "close-game"		
-	    (cond ((its game-over (my game-state))
-		   (html-replace-link "Play again"
-		     (web-game-start (game-generator (my game-state)))))
-		  (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 ((my resigned)
-	 (<p "Resigned."))
-	(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)))))))
+  (<div :class "game-state" 
+	(<div :class "game-state-body" 
+	      (<p :class "close-game"		
+		  (cond ((its game-over (my game-state))
+			 (html-replace-link "Play again"
+			   (web-game-start (game-generator (my game-state)))))
+			(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 ((my resigned)
+	       (<p "Resigned."))
+	      (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))))))))
 
 (my-defun player 'object-to-ml ()
   (<div :class "player"
@@ -303,9 +302,9 @@
 					  `(<head
 					     (<title "mopoko.com " (output-raw-ml ,title))
 					     (output-raw-ml 
-					     (<noscript
-					       (output-raw-ml 
-						(<meta :http-equiv "refresh" :content (byte-vector-cat "1000;" (page-link))))))
+					      (<noscript
+						(output-raw-ml 
+						 (<meta :http-equiv "refresh" :content (byte-vector-cat "1000;" (page-link))))))
 					     (css)
 					     (webapp-default-page-head-contents))))
 
@@ -342,7 +341,7 @@
 
   #+sbcl
   (with-preserve-specials (*trace-output* *standard-output* *error-output* *debug-io* 
-				     #+tpd2-has-swank swank::*emacs-connection*)
+					  #+tpd2-has-swank swank::*emacs-connection*)
     (sb-thread:make-thread 
      (lambda() 
        (with-specials-restored

diff --git a/src/http/request.lisp b/src/http/request.lisp
@@ -3,7 +3,9 @@
 (defprotocol http-read-chunked (con)
   (let ((body
 	 (loop 
-	       for len = (match-bind ((len (integer 16)) (* (space)) (last))  
+	       for len = (match-bind ((len (unsigned-byte :base 16 
+							  :max-len 7 ; maximum chunk size of (expt 16 7) = 268435456
+							  )) (* (space)) (last))  
 		   (io 'recvline con) 
 		 len)
 	       until (zerop len)

diff --git a/src/lib/one-liners.lisp b/src/lib/one-liners.lisp
@@ -41,35 +41,6 @@
 		:displaced-to vector
 		:displaced-index-offset start)))
 
-
-
-(declaim (inline cdr-assoc))
-(defun cdr-assoc (alist key &key (test 'eq))
-  (cdr (assoc key alist :test test)))
-
-
-(define-setf-expander cdr-assoc (place key &key (test ''eq) &environment env)
-  (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-expansion place env)
-    (with-unique-names (store key-val test-val)
-      (values 
-       (append dummies (list key-val test-val))
-       (append vals (list key test))
-       `(,store ,@newval)
-       (with-unique-names (tmp cur)
-	 `(let (,@(loop for d in dummies 
-			for v in vals
-			collect `(,d ,v))
-		(,cur ,getter))
-	    (let ((,tmp (assoc ,key-val ,cur :test ,test-val)))
-	      (cond (,tmp 
-		     (rplacd ,tmp ,store))
-		    (t
-		     (setf ,(first newval) (acons ,key ,store ,cur))
-		     ,setter))
-	      ,store)))
-       `(cdr-assoc ,getter)))))
-
 (defmacro without-call/cc (&body body)
   `(locally ,@body))
 

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -13,6 +13,7 @@
 		#:match-bind #:if-match-bind
 		#:match-failed )
   (:import-from #:cl-irregsexp.utils
+		#:cdr-assoc
 		#:defun-consistent
 		#:declaim-defun-consistent-ftype
 		#:defun-speedy

diff --git a/src/webapp/actions.lisp b/src/webapp/actions.lisp
@@ -69,12 +69,12 @@
   (defpage-lambda +action-page-name+ #'action-respond-body (.id. .channels. .javascript. all-http-params)))
 
 
-(my-defun frame 'object-to-ml ()
+(my-defun frame 'simple-channel-body-ml ()
   (<div :class "frame"
 	(<div :class "change-name" 
 	      (html-action-form "Your name " ((new-name (my username)))
 		(setf (my username) new-name)
 		(my notify)
 		(values)))
-	(output-object-to-ml (my messages))
-	(output-raw-ml (call-next-method))))
+	(output-object-to-ml (my messages))))
+
diff --git a/src/webapp/list-channel.lisp b/src/webapp/list-channel.lisp
@@ -10,8 +10,8 @@
 (my-defun list-channel del (message)
   (deletef message (my list)))
 
-(my-defun list-channel 'object-to-ml ()
+(my-defun list-channel 'simple-channel-body-ml ()
   (<div :class "list-channel"
 	(loop for x in (reverse (my list)) do
-	      (output-object-to-ml x))
-	(output-raw-ml (call-next-method))))
+	      (output-object-to-ml x))))
+
diff --git a/src/webapp/simple-channel.lisp b/src/webapp/simple-channel.lisp
@@ -14,4 +14,6 @@
 				   (simple-channel-body-ml me))))))))
 
 (my-defun simple-channel 'object-to-ml ()
-  (<div :id (my id) (simple-channel-body-ml me)))
+  (<div :id (my id) 
+	(simple-channel-body-ml me)
+	(call-next-method)))
diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -18,7 +18,7 @@
 
 (pushnew "../cl-irregsexp/" asdf:*central-registry* :test #'equal)
 
-#+comment-out
+#+tpd2-debug
 (progn
   (proclaim '(optimize debug))
   (pushnew :tpd2-debug-assert *features*))