[mcclim-cvs] CVS mcclim/Examples

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@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]