Author: hhubner Date: 2006-03-03 12:50:47 -0500 (Fri, 03 Mar 2006) New Revision: 1885 Added: branches/xml-class-rework/projects/mah-jongg/ branches/xml-class-rework/projects/mah-jongg/src/ branches/xml-class-rework/projects/mah-jongg/src/game.lisp branches/xml-class-rework/projects/mah-jongg/src/load.lisp branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd branches/xml-class-rework/projects/mah-jongg/src/package.lisp branches/xml-class-rework/projects/mah-jongg/src/test.lisp branches/xml-class-rework/projects/mah-jongg/website/ branches/xml-class-rework/projects/mah-jongg/website/bamboo.jpg branches/xml-class-rework/projects/mah-jongg/website/east.jpg branches/xml-class-rework/projects/mah-jongg/website/game.css branches/xml-class-rework/projects/mah-jongg/website/game.js branches/xml-class-rework/projects/mah-jongg/website/game.xml branches/xml-class-rework/projects/mah-jongg/website/game.xsl branches/xml-class-rework/projects/mah-jongg/website/north.jpg branches/xml-class-rework/projects/mah-jongg/website/south.jpg branches/xml-class-rework/projects/mah-jongg/website/undohtml.css branches/xml-class-rework/projects/mah-jongg/website/west.jpg Log: First version of the Mah-Jongg calculation server. Property changes on: branches/xml-class-rework/projects/mah-jongg ___________________________________________________________________ Name: svn:ignore + datastore Added: branches/xml-class-rework/projects/mah-jongg/src/game.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/game.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/game.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,139 @@ +(in-package :mah-jongg) + +(defvar *round* nil) + +(deftransaction clear-round () + (setf *round* nil)) + +(defclass player () + ((name :reader name :initarg :name) + (wind :accessor wind :initarg :wind) + (score :accessor score :initarg :score :initform 0))) + +(defmethod print-object ((player player) stream) + (print-unreadable-object (player stream :type t) + (format stream "~S (~A) SCORE: ~A" (name player) (wind player) (score player)))) + +(defun make-player (name wind) + (make-instance 'player :name name :wind wind)) + +(defun wind->player (wind) + (find wind (players *round*) :key #'wind)) + +(defun next-wind (player) + (cadr (member (wind player) '(:east :south :west :north :east)))) + +(defun east-p (player) + (eq :east (wind player))) + +(defun balance (player-1 score-1 player-2 &optional (score-2 0)) + (let ((sum (* (if (east-p player-1) 2 1) (- score-1 score-2)))) + (incf (score player-1) sum) + (decf (score player-2) sum))) + +(defclass round () + ((players :reader players :initarg :players :documentation "List of players") + (games :accessor games :initform nil) + (east-win-count :accessor east-win-count :initform 0))) + +(defun find-player (name) + (or (find name (players *round*) :key #'name :test #'string-equal) + (error "can't find player named ~S" name))) + +(deftransaction make-round (east north west south) + (setf *round* (make-instance 'round + :players (list (make-player east :east) + (make-player north :north) + (make-player west :west) + (make-player south :south))))) + +(defun rotate-winds () + (dolist (player (players *round*)) + (setf (wind player) (next-wind player)))) + +(defclass game () + ((winner :reader winner :initarg :winner) + (east :reader east :initarg :east) + (results :reader results :initarg :results :documentation "List ((<player> <score>) (...))"))) + +(defmethod print-object ((game game) stream) + (print-unreadable-object (game stream :type t) + (format stream "WINNER: ~S" (name (winner game))))) + +(deftransaction make-game (winner results) + (let* ((all-results (mapcar #'(lambda (name-score) (list (find-player (car name-score)) (cadr name-score))) results)) + (winner (find-player winner)) + (east (find-if #'east-p (players *round*))) + (winner-result (find winner all-results :key #'car)) + (other-results (remove winner all-results :key #'car))) + (dolist (loser (mapcar #'car other-results)) + (balance winner (cadr winner-result) loser)) + (apply #'balance (append (nth 0 other-results) (nth 1 other-results))) + (apply #'balance (append (nth 1 other-results) (nth 2 other-results))) + (apply #'balance (append (nth 0 other-results) (nth 2 other-results))) + (when (east-p winner) + (incf (east-win-count *round*))) + (when (or (not (east-p winner)) + (eql 4 (east-win-count *round*))) + (rotate-winds) + (setf (east-win-count *round*) 0)) + (car (push (make-instance 'game + :winner winner + :east east + :results all-results) + (games *round*))))) + +(defun round-as-xml () + (with-element "round" + (dolist (player (players *round*)) + (with-slots (name wind score) player + (with-element "player" + (attribute "name" name) + (attribute "wind" (string-downcase wind)) + (attribute "score" score)))) + (dolist (game (reverse (games *round*))) + (with-slots (winner east results) game + (with-element "game" + (dolist (player (players *round*)) + (with-element "score" + (attribute "name" (name player)) + (when (eq player winner) + (attribute "winner" "1")) + (when (eq player east) + (attribute "east" "1")) + (text (princ-to-string (cadr (find player results :key #'car))))))))))) + +(defun request-param (req name) + (assoc name (request-query req) :test #'equal)) + +(defun handle-game (req ent) + (when (eq :post (request-method req)) + (with-query-params (req action east north west south winner) + (ecase (make-keyword-from-string action) + (:make-round + (make-round east north west south)) + (:make-game + (make-game (name (wind->player (make-keyword-from-string winner))) + (mapcar #'(lambda (wind) (list (name (wind->player wind)) + (parse-integer (query-param req (symbol-name wind))))) + '(:east :north :west :south)))) + (:clear-round + (clear-round))))) + (with-http-response (req ent :content-type "text/xml") + (with-http-body (req ent) + (with-xml-output (cxml:make-character-stream-sink *html-stream*) + (sax:processing-instruction cxml::*sink* (runes:string-rod "xml-stylesheet") (runes:string-rod "type=\"text/xsl\" href=\"game.xsl\"")) + (if *round* + (round-as-xml) + (with-element "no-round")))))) + +(defun start-server (&key (port 8080)) + + (unpublish :all t) + (close-store) + + (make-instance 'store + :directory "../datastore/") + (publish :path "/game" :function 'handle-game) + (publish-directory :prefix "/" :destination "../website/") + (start :port port)) \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/src/load.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/load.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/load.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,10 @@ +(push :cl-gd-gif *features*) + +(asdf:oos 'asdf:load-op :mah-jongg) +(asdf:oos 'asdf:load-op :swank) + +(swank::create-swank-server 4005 :spawn #'swank::simple-announce-function t) + +(mah-jongg::start-server) + +(mp::startup-idle-and-top-level-loops) Added: branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/mah-jongg.asd 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,22 @@ +;;;; -*- Mode: LISP -*- + +(in-package :cl-user) + +(defpackage :mah-jongg.system + (:use :cl :asdf)) + +(in-package :mah-jongg.system) + +(defsystem :mah-jongg + :name "Mah Jongg" + :author "Hans Huebner <hans@huebner.org>" + :version "0" + :maintainer "Hans Huebner <hans@huebner.org>" + :licence "BSD" + :description "Mah Jongg game calculator" + :long-description "" + + :depends-on (:cxml :bknr :bknr-datastore :aserve) + + :components ((:file "package") + (:file "game" :depends-on ("package")))) Added: branches/xml-class-rework/projects/mah-jongg/src/package.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/package.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/package.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,12 @@ +(in-package :cl-user) + +(defpackage :mah-jongg + (:use :cl + :cl-user + :cxml + :bknr.utils + :bknr.web + :bknr.datastore + :net.aserve + :net.html.generator) + (:export)) \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/src/test.lisp =================================================================== --- branches/xml-class-rework/projects/mah-jongg/src/test.lisp 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/src/test.lisp 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,11 @@ +(in-package :mah-jongg) + +(clear-round) + +(make-round "hans" "julia" "starbug" "lisa") + +(make-game "hans" '((hans 1000) (julia 10) (starbug 20) (lisa 200))) + +(make-game "starbug" '((hans 10) (julia 100) (starbug 200) (lisa 200))) + +(players *round*) \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/bamboo.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/bamboo.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/east.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/east.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/game.css =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.css 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.css 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,67 @@ +body { + font-family: sans-serif; + background-image: url(bamboo.jpg); + height: 1200px; +} + +* { + font-size: 30px; +} + +th { + width: 120px; +} + +td, th { + background-color: #fff; +} + +td.winner { + background-color: #ccc; +} + +td { + text-align: right; +} + +tr.sum { + padding-top: 4px; +} + +td.sum { + border-style: dashed; + border-width: 4px; +} + +td img { + float: left; + margin-left: 4px; + margin-top: 4px; +} + +table { + margin: 20px; +} + +table#game-list { + position: absolute; + right: 0px; + top: 0px; +} + +table#current-game { + position: fixed; + left: 0px; + bottom: 0px; +} + +.score-input { + width: 40px; + text-align: right; +} + +#end-round-button { + position: fixed; + right: 20px; + bottom: 20px; +} \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/game.js =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.js 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,45 @@ +// -*- Java -*- + +var winds = [ 'east', 'north', 'west', 'south' ]; + +function $(name) +{ + return document.getElementById(name); +} + +function init_new_round_form() +{ + $('east').focus(); +} + +function check_new_round_form() +{ + for (i in winds) { + if ($(winds[i]).value.match(/^\s*$/)) { + $(winds[i]).focus(); + return false; + } + } + + return true; +} + +var check_new_game_inputs_interval; + +function check_new_game_inputs() +{ + if (!check_new_game_inputs_interval) { + check_new_game_inputs_interval = setInterval("check_new_game_inputs()", 300); + } + + for (i in winds) { + if ($(winds[i]).value.match(/^\s*$/)) { + $('make_game_button').disabled = 'disabled'; + return false; + } + } + + $('make_game_button').disabled = undefined; + + return true; +} Added: branches/xml-class-rework/projects/mah-jongg/website/game.xml =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xml 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xml 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,2 @@ +<?xml-stylesheet type="text/xsl" href="game.xsl"?> +<round><player name="hans" score="0" wind="EAST"></player><player name="julia" score="0" wind="NORTH"></player><player name="starbug" score="0" wind="WEST"></player><player name="lisa" score="0" wind="SOUTH"></player></round> \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/game.xsl =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/game.xsl 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,151 @@ +<?xml version="1.0" ?> + +<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns="http://www.w3.org/1999/xhtml" + version="1.0"> + + <xsl:template match="/"> + <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> + <head> + <title>Mah-Jongg</title> + <link href="undohtml.css" rel="stylesheet" type="text/css"/> + <link href="game.css" rel="stylesheet" type="text/css"/> + <script type="text/javascript" src="game.js"> </script> + </head> + <xsl:apply-templates/> + </html> + </xsl:template> + + <xsl:template match="/no-round"> + <body onload="init_new_round_form();"> + <form name="new_round_form" id="new_round_form" action="#" method="post" onsubmit="return check_new_round_form();"> + <table> + <tbody> + <tr> + <td> + <img src="east.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="east" name="east"/> + </td> + </tr> + <tr> + <td> + <img src="north.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="north" name="north"/> + </td> + </tr> + <tr> + <td> + <img src="west.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="west" name="west"/> + </td> + </tr> + <tr> + <td> + <img src="south.jpg" width="100" height="140"/> + </td> + <td> + <input type="text" id="south" name="south"/> + </td> + </tr> + <tr> + <td colspan="2"> + <button type="submit" name="action" value="make-round">Start Round</button> + </td> + </tr> + </tbody> + </table> + </form> + </body> + </xsl:template> + + <xsl:template match="/round"> + <body> + <table id="game-list"> + <thead> + <tr> + <xsl:apply-templates select="player"/> + </tr> + </thead> + <tbody> + <xsl:apply-templates select="game"/> + <tr class="sum"> + <xsl:apply-templates select="player" mode="score"/> + </tr> + </tbody> + </table> + <form method="post" action="#"> + <table id="current-game"> + <tbody> + <xsl:apply-templates select="player" mode="form"/> + <tr> + <td colspan="6"> + <button type="submit" name="action" value="make-game" disabled="disabled" id="make_game_button">Add Result</button> + </td> + </tr> + </tbody> + </table> + <button type="submit" name="action" id="end-round-button" value="clear-round">End Round</button> + </form> + </body> + </xsl:template> + + <xsl:template match="player"> + <th> + <xsl:value-of select="@name"/> + </th> + </xsl:template> + + <xsl:template match="game"> + <tr> + <xsl:apply-templates select="score"/> + </tr> + </xsl:template> + + <xsl:template match="score"> + <td> + <xsl:if test="@winner != ''"> + <xsl:attribute name="class">winner</xsl:attribute> + </xsl:if> + <xsl:if test="@east != ''"> + <img width="20" height="28" src="east.jpg"/> + </xsl:if> + <xsl:value-of select="text()"/> + </td> + </xsl:template> + + <xsl:template match="player" mode="form"> + <tr> + <td> + <img width="50" height="70" src="{@wind}.jpg"/> + </td> + <td> + <input type="radio" name="winner" value="{@wind}" onclick="check_new_game_inputs()"/> + </td> + <th> + <xsl:value-of select="@name"/> + </th> + <td> + <input autocomplete="off" id="{@wind}-score" class="score-input" onchange="input_change('{@wind}');"/> + </td> + <td> + <input autocomplete="off" id="{@wind}-doubles" class="score-input" onchange="input_change('{@wind}');" value="0"/> + </td> + <td> + <input autocomplete="off" id="{@wind}" name="{@wind}" class="score-input" readonly="readonly"/> + </td> + </tr> + </xsl:template> + + <xsl:template match="player" mode="score"> + <td class="sum"> + <xsl:value-of select="@score"/> + </td> + </xsl:template> + +</xsl:stylesheet> \ No newline at end of file Added: branches/xml-class-rework/projects/mah-jongg/website/north.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/north.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/south.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/south.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Added: branches/xml-class-rework/projects/mah-jongg/website/undohtml.css =================================================================== --- branches/xml-class-rework/projects/mah-jongg/website/undohtml.css 2006-03-03 15:36:26 UTC (rev 1884) +++ branches/xml-class-rework/projects/mah-jongg/website/undohtml.css 2006-03-03 17:50:47 UTC (rev 1885) @@ -0,0 +1,30 @@ +/* undohtml.css */ + +/* (CC) 2004 Tantek Celik. Some Rights Reserved. */ + +/* http://creativecommons.org/ licenses/by/2.0 */ +/* This style sheet is licensed under a Creative Commons License. */ +/* Purpose: undo some of the default styling of common (X)HTML browsers */ +/* link underlines tend to make hypertext less readable, + because underlines obscure the shapes of the lower + halves of words */ +:link,:visited { text-decoration:none } + +/* no list-markers by default, since lists are used more + often for semantics */ +ul,ol { list-style:none } + +/* avoid browser default inconsistent heading font-sizes */ +h1,h2,h3,h4,h5,h6 { font-size:1em; } + +/* remove the inconsistent (among browsers) default ul,ol + padding or margin */ +/* the default spacing on headings does not match nor align + with normal interline spacing at all, so let's get rid of it. */ +/* zero out the spacing around pre, form, body, html, p, + blockquote as well */ +/* form elements are oddly inconsistent, + and not quite CSS emulatable. */ +/* nonetheless strip their margin and padding as well */ +ul,ol,li,h1,h2,h3,h4,h5,h6,pre,form,body,html,p, blockquote,fieldset,input { margin:0; padding:0 } + Added: branches/xml-class-rework/projects/mah-jongg/website/west.jpg =================================================================== (Binary files differ) Property changes on: branches/xml-class-rework/projects/mah-jongg/website/west.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream