[mcclim-cvs] CVS mcclim/Examples
ahefner
ahefner at common-lisp.net
Mon Jul 3 04:58:41 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Examples
In directory clnet:/tmp/cvs-serv13277/Examples
Modified Files:
demodemo.lisp
Added Files:
logic-cube.lisp
Log Message:
Add "Logic Cube" example.
--- /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/05/12 22:40:51 1.12
+++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/07/03 04:58:41 1.13
@@ -61,6 +61,7 @@
(make-demo-button "Method Browser" 'method-browser)
(make-demo-button "Address Book" 'address-book)
(make-demo-button "Puzzle" 'puzzle)
+ (make-demo-button "Logic Cube" 'logic-cube)
(make-demo-button "Gadget Test" 'gadget-test)
(make-demo-button "Drag and Drop" 'dragndrop)
(make-demo-button "Colorslider" 'colorslider)
--- /project/mcclim/cvsroot/mcclim/Examples/logic-cube.lisp 2006/07/03 04:58:41 NONE
+++ /project/mcclim/cvsroot/mcclim/Examples/logic-cube.lisp 2006/07/03 04:58:41 1.1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-DEMO; -*-
;;; 3D Logic Cube flash game (http://www.newgrounds.com/portal/view/315702),
;;; translated into CL/McCLIM.
;;; (C) Copyright 2006 by Andy Hefner (ahefner at gmail.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
(in-package :clim-demo)
;; TODO: Improved puzzle generator. The puzzles currently generated by
;; "Random Puzzle" are all extremely easy to solve. I'm not admitting
;; defeat here, but I refuse to waste any more time on this program.
;; FIXME: When shrinking polygons during the victory animation, why
;; does their shape appear to distort? Look at the Z of the transformed
;; coordinates..
;; Pane definition and puzzle generator
(defclass logic-cube-pane (basic-gadget)
((background :initform (make-rgb-color 0.35 0.35 0.46) :reader background-color)
(pitch :initform 0.0 :accessor pitch)
(yaw :initform 0.0 :accessor yaw)
(density :initform 5 :accessor density)
(playfield :reader playfield)
(drag-color :initform nil :accessor drag-color)
(dragging :initform nil :accessor dragging)
(squeeze :initform nil :accessor squeeze) ; For victory animation
(flyaway :initform 0.0 :accessor flyaway) ; For victory animation
(decorator :initform nil :accessor decorator))) ; Hook for victory text
(defun reset-logic-cube (cube new-density)
(with-slots (density playfield squeeze drag-color dragging flyaway decorator) cube
(setf density new-density
dragging nil
decorator nil
drag-color nil
flyaway 0.0
squeeze nil
playfield (make-array (list 3 density density) :initial-element (list nil nil)))))
;; Playfield squares are a pair of color and {nil, t, terminal}
(defun scrub-square (square) (if (second square) square (list nil nil)))
(defun cleanup-cube (cube)
(apply-to-hemicube-faces (density cube)
(lambda (side i j &rest points)
(declare (ignore points))
(symbol-macrolet ((square (aref (playfield cube) side i j)))
(setf square (scrub-square square))))))
(defparameter *logic-cube-colors* (list +red+ +yellow+ +blue+ +green+ +orange+ +purple+))
; Produce crappy, trivial puzzles, slowly.
(defun generate-cube-puzzle (cube &optional (num-colors 6))
(reset-logic-cube cube 5)
(labels ((sq (s i j) (first (aref (playfield cube) s i j)))
(sql (indices) (apply #'sq indices))
(set-playfield (indices square)
(destructuring-bind (s i j) indices
(setf (aref (playfield cube) s i j) square)))
(satisfying (pred)
(loop for tries from 0 by 1
as s = (random 3)
as i = (random (density cube))
as j = (random (density cube))
as result = (funcall pred (sq s i j) s i j)
while (< tries (expt (density cube) 4)) ; ^_^
when result return result)))
(let ((iterators
(loop for color-index from 0 below num-colors collect
(destructuring-bind (root iterator)
(satisfying
(lambda (color &rest root-indices)
(let ((our-color (elt *logic-cube-colors* color-index))
(current-head root-indices))
(when (null color)
(labels
((find-new-head ()
(satisfying ;; Obviously I should not use 'satisfying' here..
(lambda (head-color &rest head-indices)
(and (null head-color) ;; .. but computers are very fast.
(not (equal head-indices current-head))
(member head-indices (apply #'adjacent-squares cube current-head) :test #'equal)
(>= 1 (count-if (lambda (c) (eql c our-color))
(apply #'adjacent-squares cube head-indices)
:key #'sql))
head-indices))))
(choose-new-head ()
(let ((new-head (find-new-head)))
(if new-head
(set-playfield new-head (list our-color nil))
(unless (equal current-head root-indices)
(set-playfield current-head (list our-color 'terminal))))
(setf current-head new-head)
(and new-head #'choose-new-head))))
(choose-new-head)
(and current-head (list root-indices #'choose-new-head)))))))
(set-playfield root (list (elt *logic-cube-colors* color-index) 'terminal))
iterator))))
(loop for i from 0 by 1
while (and iterators (< i 100))
do (setf iterators (remove nil (mapcar #'funcall iterators))))
(apply-to-hemicube-faces (density cube)
(lambda (side i j &rest points)
(declare (ignore points))
(when (and (null (sq side i j))
(< (random 1.0) 0.65))
(set-playfield (list side i j) (list nil t))))))))
;; The puzzles coming out of the above were so bad that I threw this together to
;; reject some of the obviously awful ones.
(defun generate-better-cube-puzzle (cube &optional (num-colors 6))
(loop for i from 0 below 100 do
(generate-cube-puzzle cube num-colors)
(multiple-value-bind (solvable min-path-length)
(check-victory cube)
(assert solvable)
(when (>= min-path-length 6)
(return-from generate-better-cube-puzzle))))
(format *trace-output* "~&Settling for lousy puzzle..~%"))
(defmethod initialize-instance :after ((pane logic-cube-pane) &rest args)
(declare (ignore args))
(generate-better-cube-puzzle pane 6)
(cleanup-cube pane))
(defmethod compose-space ((pane logic-cube-pane) &key width height)
(declare (ignore width height))
;; Hmm. How does one constrain the aspect ratio of a pane?
(make-space-requirement :min-width 200
:min-height 200
:width 550
:height 550))
;; Math utilities
(defun lc-scaling-matrix (scale)
(let ((matrix (make-array '(3 3) :initial-element 0.0)))
(dotimes (i 3) (setf (aref matrix i i) scale))
matrix))
(defun lc-m3xv3 (a b) ; multiply 3x3 matrix by vector
(flet ((f (i) (loop for j from 0 below 3 sum (* (aref a i j) (elt b j)))))
(vector (f 0) (f 1) (f 2))))
(defun lc-m3xm3 (a b) ; multiply two 3x3 matrices
(let ((matrix (make-array '(3 3) :initial-element 0.0)))
(dotimes (row 3)
(dotimes (col 3)
(dotimes (i 3)
(incf (aref matrix row col) (* (aref a row i) (aref b i col))))))
matrix))
(defun lc-rotation-matrix (theta axis-a axis-b)
(let ((matrix (lc-scaling-matrix 1.0)))
(setf (aref matrix axis-a axis-a) (cos theta)
(aref matrix axis-a axis-b) (sin theta)
(aref matrix axis-b axis-a) (- (sin theta))
(aref matrix axis-b axis-b) (cos theta))
matrix))
(defun lc-v+ (a b) (map 'vector #'+ a b)) ; 3-vector addition a+b
(defun lc-v- (a b) (map 'vector #'- a b)) ; 3-vector subtract a-b
(defun lc-scale (a s) (map 'vector (lambda (x) (* x s)) a)) ; 3-vector multiply by scalar
(defun lc-cross (a b) ; 3-vector cross product
(macrolet ((woo (p q)
`(- (* (elt a ,p) (elt b ,q ))
(* (elt a ,q) (elt b ,p)))))
(vector (woo 1 2)
(woo 2 0)
(woo 0 1))))
;; Corner of hemicube is at origin.
;; Sides: 0=XY 1=XZ 2=YZ
(defun apply-to-hemicube-faces (n fn)
(let ((size (/ n)))
(dotimes (d 3)
(flet ((permute (x y)
; SBCL warns (erroneously?) below, but the code works.
(flet ((f (i) (elt (vector x y 0) (mod (+ d i) 3))))
(vector (f 0) (f 1) (f 2)))))
(dotimes (i n)
(dotimes (j n)
(let ((base-x (* i size))
(base-y (* j size)))
(funcall fn d i j
(permute base-x base-y)
(permute (+ base-x size) base-y)
(permute (+ base-x size) (+ base-y size))
(permute base-x (+ base-y size))))))))))
(defun lc-point-transformer (view-matrix)
(lambda (point)
(setf point (map 'vector (lambda (x) (- x 0.5)) point))
(setf point (lc-m3xv3 view-matrix point))
(let ((z (+ 2.0 (elt point 2)))
(zoom 2.0))
(vector (* zoom (/ (elt point 0) z))
(* zoom (/ (elt point 1) z))
z))))
(defun lc-scale-polygon (polygon amount)
(let ((center (reduce (lambda (a b) (lc-v+ a (lc-scale b (/ (length polygon))))) polygon
:initial-value #(0.0 0.0 0.0))))
(mapcar (lambda (v) (lc-v+ center (lc-scale (lc-v- v center) amount))) polygon)))
(defun draw-polygon-3d (pane points &rest polygon-args)
(apply #'draw-polygon pane
(mapcar (lambda (p) (make-point (elt p 0) (elt p 1))) points)
polygon-args))
(defun apply-to-transformed-faces (pane continuation)
(let ((transformer (lc-point-transformer
(lc-m3xm3 (lc-scaling-matrix (- 1.0 (flyaway pane)))
(lc-m3xm3 (lc-rotation-matrix (pitch pane) 1 2)
(lc-rotation-matrix (yaw pane) 0 2))))))
(apply-to-hemicube-faces (density pane)
(lambda (side i j &rest points)
(apply continuation side i j (mapcar transformer points))))))
(defun lc-face-normal (points)
(lc-cross (lc-v- (elt points 2)
(elt points 1))
(lc-v- (elt points 0)
(elt points 1))))
(defun backface-p (points)
(<= (elt (lc-face-normal points) 2) 0))
(defun face-light (color side)
(compose-over (compose-in color (make-opacity 0.65))
(elt (vector +gray30+ +white+ color) side)))
(defun polygon-edges (points)
(maplist (lambda (list)
(lc-v- (or (second list) (first points)) (first list)))
points))
(defun draw-polygon-outline-3d (pane a b &rest polygon-args)
(maplist (lambda (a* b*)
(apply #'draw-polygon-3d pane
(list (first a*)
(first b*)
(or (second b*) (first b))
(or (second a*) (first a)))
polygon-args))
a b))
(defun draw-logic-cube (pane)
(apply-to-transformed-faces pane
(lambda (side i j &rest camera-points)
(unless (backface-p camera-points)
(when (squeeze pane)
(setf camera-points (lc-scale-polygon camera-points (squeeze pane))))
(destructuring-bind (color type) (aref (playfield pane) side i j)
(cond
((null type)
(draw-polygon-3d pane (lc-scale-polygon camera-points 0.8)
:filled t :ink (face-light (or color +gray80+) side)))
((eql type 'terminal)
(let ((selected (eql color (drag-color pane))))
(when selected (draw-polygon-3d pane camera-points :filled t :ink color))
(draw-polygon-outline-3d pane camera-points (lc-scale-polygon camera-points 0.7)
:filled t
:ink (if selected
+white+
(face-light (or color +gray80+) side)))))))))))
(defun invoke-in-lc-space (pane continuation) ; "logic-cube space" =p
(let* ((width (bounding-rectangle-width pane))
(height (bounding-rectangle-height pane))
(radius (/ (min width height) 2)))
(with-translation (pane (/ width 2) (/ height 2))
(with-scaling (pane radius)
(funcall continuation pane)))))
(defmethod handle-repaint ((pane logic-cube-pane) region)
(with-bounding-rectangle* (x0 y0 x1 y1) (sheet-region pane)
(climi::with-double-buffering ((pane x0 y0 x1 y1) (wtf-wtf-wtf))
(declare (ignore wtf-wtf-wtf))
(draw-rectangle* pane x0 y0 x1 y1 :filled t :ink (background-color pane))
(invoke-in-lc-space pane #'draw-logic-cube)
(when (decorator pane)
(funcall (decorator pane))))))
;;; Locating the face under the pointer:
(defun square (x) (* x x))
(defun point-in-poly-p (x y points)
(every (lambda (point edge)
(let* ((edge-length (sqrt (+ (square (elt edge 0)) (square (elt edge 1)))))
(nx (/ (- (elt edge 1)) edge-length))
(ny (/ (elt edge 0) edge-length))
(c (+ (* nx (elt point 0))
(* ny (elt point 1)))))
(< c (+ (* nx x) (* ny y)))))
points
(polygon-edges points)))
(defun xy-to-viewport-coordinates (pane x y)
(let* ((width (bounding-rectangle-width pane)) ; ..
(height (bounding-rectangle-height pane))
(radius (/ (min width height) 2)))
(values (/ (- x (/ width 2)) radius)
(/ (- y (/ height 2)) radius))))
(defun find-poly-under-point (pane x y)
(apply-to-transformed-faces pane
(lambda (side i j &rest points)
(unless (backface-p points)
(when (point-in-poly-p x y points)
(return-from find-poly-under-point (values side i j))))))
(values nil nil nil))
;;; Game interaction:
(defmethod handle-event ((pane logic-cube-pane) (event pointer-exit-event))
(setf (dragging pane) nil))
(defmethod handle-event ((pane logic-cube-pane) (event pointer-button-release-event))
(setf (dragging pane) nil))
(defun square+ (pane side i j di dj)
(let ((ni (+ i di))
(nj (+ j dj)))
(if (or (> 0 ni)
(> 0 nj)
(>= ni (density pane))
(>= nj (density pane)))
nil
(list side ni nj))))
(defun adjacent-squares (pane side i j)
(remove nil ; Ouch..
(list (square+ pane side i j 1 0)
(square+ pane side i j 0 1)
(or (square+ pane side i j -1 0)
(and (= side 2) (list 1 j 0))
(and (= side 0) (list 2 j 0))
(and (= side 1) (list 0 j 0)))
(or (square+ pane side i j 0 -1)
(and (= side 2) (list 0 0 i))
(and (= side 1) (list 2 0 i))
(and (= side 0) (list 1 0 i))))))
(defun check-victory (pane)
(let ((success t)
(min-path-length nil))
(apply-to-hemicube-faces (density pane)
(lambda (side i j &rest points)
(declare (ignore points))
(when (eql 'terminal (second (aref (playfield pane) side i j)))
(let ((coverage (make-hash-table :test 'equal))
(color (first (aref (playfield pane) side i j))))
(labels ((searching (path-length &rest indices)
(setf (gethash indices coverage) t)
(some (lambda (indices)
(destructuring-bind (color-2 type) (apply #'aref (playfield pane) indices)
(and (eql color color-2)
(not (gethash indices coverage))
(or (and (eql type 'terminal)
(setf min-path-length (if min-path-length
(min min-path-length path-length)
path-length)))
(apply #'searching (1+ path-length) indices)))))
(apply #'adjacent-squares pane indices))))
(unless (searching 1 side i j)
(setf success nil)))))))
(values success min-path-length))) ; Successful if no unconnected roots remained
(defun won-logic-cube (pane)
[82 lines skipped]
More information about the Mcclim-cvs
mailing list