[bknr-cvs] r1885 - in branches/xml-class-rework/projects: . mah-jongg mah-jongg/src mah-jongg/website
bknr at bknr.net
bknr at bknr.net
Fri Mar 3 17:50:47 UTC 2006
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 at huebner.org>"
+ :version "0"
+ :maintainer "Hans Huebner <hans at 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
More information about the Bknr-cvs
mailing list