Changes to move all games to Racket from Mzscheme.
Signed-off-by: Patrick Mahoney <paddy.mahoney@gmail.com>
This commit is contained in:
Patrick Mahoney
Eli Barzilay
parent
0ded7e4e26
commit
894d7267fb
|
|
@ -5,10 +5,10 @@ possible to remap single click (instead of double click)?
|
|||
|
||||
|#
|
||||
|
||||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require games/cards mred mzlib/class mzlib/list mzlib/unit string-constants
|
||||
"../show-scribbling.ss")
|
||||
(require games/cards racket/gui racket/class racket/unit string-constants
|
||||
"../show-scribbling.rkt")
|
||||
|
||||
(provide game@)
|
||||
(define game@ (unit (import) (export)
|
||||
|
|
@ -29,7 +29,7 @@ possible to remap single click (instead of double click)?
|
|||
;; space between cards in the 4 stacks
|
||||
(define card-space 30)
|
||||
|
||||
(define-struct stack (x y cards))
|
||||
(define-struct stack (x y cards) #:mutable)
|
||||
|
||||
(define (get-x-offset n)
|
||||
(let* ([table-width (send table table-width)]
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define game "aces.scm")
|
||||
(define game "aces.rkt")
|
||||
(define game-set "Card Games")
|
||||
|
|
|
|||
|
|
@ -29,9 +29,9 @@
|
|||
;;
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require games/cards mred mzlib/class mzlib/list mzlib/unit)
|
||||
(require games/cards racket/gui racket/class racket/unit)
|
||||
|
||||
(provide game@)
|
||||
(define game@ (unit (import) (export)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require "cards/cards.rkt")
|
||||
(provide (all-from "cards/cards.rkt"))
|
||||
(provide (all-from-out "cards/cards.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(module base mzscheme
|
||||
(require mzlib/class mzlib/etc
|
||||
(module base racket
|
||||
(require racket/class
|
||||
"make-cards.rkt" "classes.rkt" "card-class.rkt")
|
||||
|
||||
(provide make-table make-deck make-card
|
||||
|
|
@ -9,7 +9,7 @@
|
|||
(define card<%> (class->interface card%))
|
||||
|
||||
(define make-table
|
||||
(opt-lambda ([title "Cards"][w 7][h 3])
|
||||
(lambda ([title "Cards"][w 7][h 3])
|
||||
(make-object table% title w h)))
|
||||
|
||||
(define (make-deck)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(module card-class racket/base
|
||||
(require racket/class
|
||||
racket/shared
|
||||
(prefix-in mred: mred)
|
||||
(prefix-in mred: racket/gui)
|
||||
"snipclass.rkt"
|
||||
"region.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
(module cards mzscheme
|
||||
(module cards racket
|
||||
(require "base.rkt"
|
||||
"utils.rkt"
|
||||
"region.rkt")
|
||||
|
||||
(provide table<%> card<%>
|
||||
region struct:region
|
||||
region struct:region
|
||||
make-region
|
||||
region? region-x region-y region-w region-h
|
||||
region-label region-callback region-interactive-callback
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
(module classes racket/base
|
||||
(require racket/class
|
||||
(prefix-in mred: mred)
|
||||
racket/list
|
||||
(prefix-in mred: racket/gui)
|
||||
(prefix-in util: "utils.rkt")
|
||||
"constants.rkt"
|
||||
"make-cards.rkt"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(module constants mzscheme
|
||||
(require mzlib/class
|
||||
mred)
|
||||
(module constants racket
|
||||
(require racket/class
|
||||
racket/gui)
|
||||
|
||||
(provide ANIMATION-STEPS
|
||||
ANIMATION-TIME
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require "cards.rkt")
|
||||
(provide (all-from "cards.rkt"))
|
||||
(provide (all-from-out "cards.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
(module make-cards mzscheme
|
||||
(require mzlib/class
|
||||
(prefix mred: mred)
|
||||
(prefix card-class: "card-class.rkt"))
|
||||
(module make-cards racket
|
||||
(require racket/class
|
||||
(prefix-in mred: racket/gui)
|
||||
(prefix-in card-class: "card-class.rkt"))
|
||||
|
||||
(provide back deck-of-cards make-card)
|
||||
|
||||
|
|
@ -61,7 +61,7 @@
|
|||
front back
|
||||
(lambda () (make-dim front))
|
||||
(lambda () dim-back)
|
||||
(make-hash-table 'equal))
|
||||
(make-hash))
|
||||
(vloop (sub1 value))))))))))
|
||||
|
||||
(define (make-card front-bm back-bm suit-id value)
|
||||
|
|
@ -77,4 +77,4 @@
|
|||
(if back-bm
|
||||
(make-dim back)
|
||||
dim-back))
|
||||
(make-hash-table 'equal)))))
|
||||
(make-hash)))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(module region mzscheme
|
||||
(module region racket
|
||||
(provide region
|
||||
struct:region make-region
|
||||
region? region-x region-y region-w region-h
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
(module snipclass mzscheme
|
||||
(require mred
|
||||
mzlib/class)
|
||||
(module snipclass racket
|
||||
(require racket/gui
|
||||
racket/class)
|
||||
(provide sc)
|
||||
|
||||
(define sc (make-object snip-class%))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(module utils mzscheme
|
||||
(module utils racket
|
||||
(provide shuffle-list)
|
||||
|
||||
(define shuffle-list
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@
|
|||
(o-loop (cdr objs))]))]))))
|
||||
|
||||
;; a hack.
|
||||
;; this adds a help button to the world.ss window
|
||||
;; this adds a help button to the world.rkt window
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ([n 0])
|
||||
|
|
@ -66,6 +66,6 @@
|
|||
|
||||
(parameterize ([current-custodian sub-custodian])
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-attach-module orig-namespace 'mred/mred)
|
||||
(namespace-attach-module orig-namespace 'racket/gui)
|
||||
(namespace-attach-module orig-namespace 'racket/class)
|
||||
((dynamic-require chat-noir 'main)))))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(provide make-immutable-hash/list-init
|
||||
hash-set hash-ref hash-map)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,15 +1,12 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require games/gl-board-game/gl-board
|
||||
mzlib/class
|
||||
mzlib/math
|
||||
mred
|
||||
mzlib/unit
|
||||
racket/gui
|
||||
racket/unit
|
||||
sgl/gl-vectors
|
||||
sgl
|
||||
sgl/gl
|
||||
srfi/25/array
|
||||
mrlib/include-bitmap
|
||||
"honu-bitmaps.rkt")
|
||||
(provide game@)
|
||||
|
||||
|
|
@ -43,9 +40,10 @@
|
|||
(make-image (send bmp get-width) (send bmp get-height)
|
||||
(argb->rgba (bitmap->argb bmp))))
|
||||
|
||||
(define light-square-img (bitmap->image (include-bitmap "light.jpg")))
|
||||
#;(define light-square-img (bitmap->image (include-bitmap "light.jpg")))
|
||||
(define light-square-img (bitmap->image (make-object bitmap% (build-path (collection-file-path "light.jpg" "games" "checkers")))))
|
||||
(define light-square-color (gl-float-vector .7216 .6471 .5176 1))
|
||||
(define dark-square-img (bitmap->image (include-bitmap "dark.jpg")))
|
||||
(define dark-square-img (bitmap->image (make-object bitmap% (build-path (collection-file-path "dark.jpg" "games" "checkers")))))
|
||||
(define dark-square-color (gl-float-vector .4745 .3569 .2627 1))
|
||||
|
||||
(define (color-name->vector name darken?)
|
||||
|
|
@ -62,7 +60,7 @@
|
|||
(define dark-checker-img (bitmap->image honu-bitmap))
|
||||
|
||||
(define-struct space-info (x y light?))
|
||||
(define-struct piece-info (x y color king?) (make-inspector))
|
||||
(define-struct piece-info (x y color king?) #:inspector (make-inspector))
|
||||
(define-struct moves (list forced-jump?))
|
||||
|
||||
(define-signature model^
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
(module honu-bitmaps mzscheme
|
||||
(require mzlib/math
|
||||
mzlib/etc
|
||||
mred
|
||||
mzlib/class)
|
||||
(module honu-bitmaps racket
|
||||
(require racket/math
|
||||
racket/gui
|
||||
racket/class)
|
||||
|
||||
(provide honu-bitmap honu-down-bitmap
|
||||
honu-rotation honu-down-rotation)
|
||||
|
|
@ -16,7 +15,7 @@
|
|||
(+ y (* h 1/2) (* h 1/2 se)))))
|
||||
|
||||
(define weighted-arc
|
||||
(opt-lambda (path x y w h start end ccw? [dx1 0.0] [dy1 0.2] [dx2 dx1] [dy2 (- dy1)])
|
||||
(lambda (path x y w h start end ccw? [dx1 0.0] [dy1 0.2] [dx2 dx1] [dy2 (- dy1)])
|
||||
(let ([sweep (let loop ([s (if ccw? (- end start) (- start end))])
|
||||
(if (< s 0)
|
||||
(loop (+ s (* 2 pi)))
|
||||
|
|
@ -273,7 +272,7 @@
|
|||
(let ([right-hole-path (make-object dc-path%)])
|
||||
|
||||
(define arc/end
|
||||
(opt-lambda (x y w h start end [cc? #t] [dx1 0] [dy1 0.2] [dx2 0] [dy2 -0.2])
|
||||
(lambda (x y w h start end [cc? #t] [dx1 0] [dy1 0.2] [dx2 0] [dy2 -0.2])
|
||||
(weighted-arc right-hole-path x y w h start end cc? dx1 dy1 dx2 dy2)
|
||||
(find-arc-spot x y w h end)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
|
||||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require games/cards mred mzlib/class mzlib/unit mzlib/etc mzlib/list mzlib/file
|
||||
mzlib/async-channel)
|
||||
(require games/cards racket/gui racket/class racket/unit racket/file
|
||||
racket/async-channel)
|
||||
|
||||
;; Player record
|
||||
(define-struct player (r hand-r ; region
|
||||
hand)) ; cards
|
||||
hand) #:mutable) ; cards
|
||||
|
||||
;; Messages
|
||||
(define YOUR-NAME "You")
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
(module doors mzscheme
|
||||
(module doors racket
|
||||
(require games/gl-board-game/gl-board
|
||||
sgl/gl-vectors
|
||||
sgl
|
||||
sgl/bitmap
|
||||
mred
|
||||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/class)
|
||||
racket/gui
|
||||
racket/class)
|
||||
|
||||
(provide door-game%
|
||||
player-data
|
||||
|
|
@ -18,10 +16,10 @@
|
|||
(define light-blue (gl-float-vector 0.5 0.5 1.0 0.5))
|
||||
(define light-red (gl-float-vector 1.0 0.5 0.5 0.5))
|
||||
|
||||
(define-struct room (data players things))
|
||||
(define-struct wall (drawer))
|
||||
(define-struct player (data drawer i j))
|
||||
(define-struct thing (data drawer i j heads-up?))
|
||||
(define-struct room (data players things) #:mutable)
|
||||
(define-struct wall (drawer) #:mutable)
|
||||
(define-struct player (data drawer i j) #:mutable)
|
||||
(define-struct thing (data drawer i j heads-up?) #:mutable)
|
||||
|
||||
(define (bitmap->drawer bm game)
|
||||
(let*-values ([(bm mask)
|
||||
|
|
@ -127,13 +125,13 @@
|
|||
(gl-end-list)
|
||||
list-id)))))
|
||||
|
||||
(define cache (make-hash-table 'equal))
|
||||
(define cache (make-hash))
|
||||
(define/private (make-wall-dl/cached dir door?)
|
||||
(let ([key (list dir door?)])
|
||||
(hash-table-get cache key
|
||||
(hash-ref cache key
|
||||
(lambda ()
|
||||
(let ([dl (make-wall-dl dir door?)])
|
||||
(hash-table-put! cache key dl)
|
||||
(hash-set! cache key dl)
|
||||
dl)))))
|
||||
|
||||
(define/private (make-wall-draw dx dy dir door)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
(module graph mzscheme
|
||||
(require mzlib/class
|
||||
"private/utils.rkt")
|
||||
(require-for-syntax "private/utils.rkt")
|
||||
(module graph racket
|
||||
(require racket/class
|
||||
"private/utils.rkt"
|
||||
(for-syntax "private/utils.rkt"))
|
||||
|
||||
|
||||
(provide node% edge%
|
||||
grid-graph)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(module utils mzscheme
|
||||
(module utils racket
|
||||
(provide alternates
|
||||
interleave)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,9 @@
|
|||
(module utils mzscheme
|
||||
(module utils racket
|
||||
(require sgl/gl-vectors
|
||||
sgl
|
||||
mzlib/math
|
||||
mred
|
||||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/class
|
||||
mzlib/kw
|
||||
racket/math
|
||||
racket/gui
|
||||
racket/class
|
||||
"doors.rkt")
|
||||
|
||||
(provide door-bm
|
||||
|
|
@ -106,7 +103,7 @@
|
|||
(gl-end-list)
|
||||
list-id))))
|
||||
|
||||
(define/kw (make-i-player-icon game
|
||||
(define (make-i-player-icon game
|
||||
#:optional
|
||||
[data #f]
|
||||
#:key
|
||||
|
|
@ -183,14 +180,14 @@
|
|||
(gl-light-model-v 'light-model-ambient (gl-float-vector 1.0 1.0 1.0 0.0))
|
||||
(gl-disable 'light0)))
|
||||
|
||||
(define/kw (make-key-thing-icon game
|
||||
(define (make-key-thing-icon game
|
||||
#:optional
|
||||
[data #f]
|
||||
#:key
|
||||
[color yellow])
|
||||
(let ([dl (make-key-dl game color)])
|
||||
(send game make-thing-icon
|
||||
(lambda/kw (#:optional [just-shadow? #f])
|
||||
(lambda (#:optional [just-shadow? #f])
|
||||
(with-light just-shadow? (lambda ()
|
||||
(gl-scale 0.5 0.5 0.5)
|
||||
(gl-call-list dl))))
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -3,9 +3,9 @@
|
|||
;;; based on http://www.grame.fr/Research/GCalcul/Graphic_Calculus.html
|
||||
;;; implemented by Eli Barzilay.
|
||||
|
||||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require mzlib/class mred mzlib/etc "../show-scribbling.rkt" mzlib/unit)
|
||||
(require racket/gui "../show-scribbling.rkt" racket/unit (only-in mzscheme fluid-let))
|
||||
(provide game@)
|
||||
|
||||
(define customs '())
|
||||
|
|
@ -335,13 +335,13 @@
|
|||
;;;============================================================================
|
||||
;;; GCalc drawing
|
||||
|
||||
(define transparent?-cache (make-hash-table 'weak))
|
||||
(define transparent?-cache (make-weak-hash))
|
||||
|
||||
(define (expr-contains-transparent? expr)
|
||||
(if (simple-expr? expr)
|
||||
(or (null-expr? expr) (eq? expr 'transparent)
|
||||
(and (var-expr? expr) (eq? (var-val expr) 'transparent)))
|
||||
(let ([v (hash-table-get transparent?-cache expr 'unknown)])
|
||||
(let ([v (hash-ref transparent?-cache expr 'unknown)])
|
||||
(if (eq? v 'unknown)
|
||||
(let ([v (cond [(abstraction-expr? expr)
|
||||
(expr-contains-transparent? (expr-2nd expr))]
|
||||
|
|
@ -349,7 +349,7 @@
|
|||
#t]
|
||||
[else (or (expr-contains-transparent? (expr-1st expr))
|
||||
(expr-contains-transparent? (expr-2nd expr)))])])
|
||||
(hash-table-put! transparent?-cache expr v)
|
||||
(hash-set! transparent?-cache expr v)
|
||||
v)
|
||||
v))))
|
||||
|
||||
|
|
@ -555,8 +555,8 @@
|
|||
gcalc-frame '(ok)))))
|
||||
(save-as)))
|
||||
(define (open-examples)
|
||||
(open (path->string (build-path (this-expression-source-directory)
|
||||
"gcalc-examples"))))
|
||||
(open (path->string (build-path (collection-file-path "gcalc-examples" "games" "gcalc" )))))
|
||||
|
||||
(define (open . file)
|
||||
(maybe-save)
|
||||
(let ([f (if (not (null? file))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "gl-board-game/gl-board.rkt")
|
||||
(provide (all-from-out "gl-board-game/gl-board.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
(module gl-board mzscheme
|
||||
(module gl-board racket
|
||||
(require sgl
|
||||
sgl/gl
|
||||
sgl/gl-vectors
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mred)
|
||||
racket/class
|
||||
racket/list
|
||||
racket/gui)
|
||||
|
||||
(provide gl-board%)
|
||||
|
||||
(define-struct space (draw info))
|
||||
(define-struct piece (x y z draw info enabled?))
|
||||
(define-struct heads-up (w h draw info))
|
||||
(define-struct space (draw info) #:mutable)
|
||||
(define-struct piece (x y z draw info enabled?) #:mutable)
|
||||
(define-struct heads-up (w h draw info) #:mutable)
|
||||
|
||||
(define (get-info x)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "gl-board.rkt")
|
||||
(provide (all-from-out "gl-board.rkt"))
|
||||
|
|
|
|||
|
|
@ -3,10 +3,8 @@
|
|||
;; speed up future games (i.e., converts learned strategy to a compact
|
||||
;; form).
|
||||
|
||||
(module check mzscheme
|
||||
(module check racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
"sig.rkt"
|
||||
"model.rkt"
|
||||
"explore.rkt"
|
||||
|
|
@ -35,7 +33,7 @@
|
|||
|
||||
(let ([search (mk-search)]
|
||||
[cnt 0]
|
||||
[move-map (make-hash-table 'equal)]
|
||||
[move-map (make-hash)]
|
||||
[canonicalize (make-canonicalize)])
|
||||
(let loop ([board empty-board]
|
||||
[depth 0]
|
||||
|
|
@ -54,7 +52,7 @@
|
|||
[else
|
||||
(let ([key+xform (canonicalize board 'red)])
|
||||
(list-ref
|
||||
(hash-table-get
|
||||
(hash-ref
|
||||
move-map (car key+xform)
|
||||
(lambda ()
|
||||
(let ([play (search 300.0 1 2 'red board history)])
|
||||
|
|
@ -105,10 +103,10 @@
|
|||
(apply-xform (cdr key+xform)
|
||||
(list-ref play 3) (list-ref play 4))
|
||||
(add1 max-depth))])
|
||||
(hash-table-put! move-map (car key+xform) l)
|
||||
(hash-set! move-map (car key+xform) l)
|
||||
l))))))
|
||||
3))]))
|
||||
(hash-table-for-each move-map
|
||||
(hash-for-each move-map
|
||||
(lambda (k v)
|
||||
(when (> (list-ref v 3) 1)
|
||||
(printf "~s\n" (cons k v)))))))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
;; This is the main search engine for auto-play.
|
||||
;; See `make-search' for the main entry point.
|
||||
|
||||
(module explore mzscheme
|
||||
(module explore racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
"sig.rkt"
|
||||
"test.rkt")
|
||||
|
||||
|
|
@ -42,7 +40,7 @@
|
|||
;; with `make-plan', described below.
|
||||
(define (make-search make-rate-board make-canned-moves)
|
||||
;; Long-term memory (i.e., spans searches)
|
||||
(define init-memory (make-hash-table 'equal))
|
||||
(define init-memory (make-hash))
|
||||
(define canonicalize (make-canonicalize))
|
||||
(define rate-board (make-rate-board canonicalize))
|
||||
(define canned-moves (make-canned-moves canonicalize init-memory))
|
||||
|
|
@ -60,15 +58,15 @@
|
|||
[once-sema (make-semaphore)]
|
||||
[result-sema (make-semaphore)]
|
||||
;; Short-term memory (i.e., discarded after this search)
|
||||
[memory (make-hash-table 'equal)])
|
||||
[memory (make-hash)])
|
||||
;; Record game-history boards as loop ties
|
||||
(let loop ([history history][me (other me)])
|
||||
(unless (null? history)
|
||||
(let ([key+xform (canonicalize (car history) me)])
|
||||
(hash-table-put! memory (car key+xform) LOOP-TIE))
|
||||
(hash-set! memory (car key+xform) LOOP-TIE))
|
||||
(loop (cdr history) (other me))))
|
||||
;; Copy canned and learned info into short-term memory:
|
||||
(hash-table-for-each init-memory (lambda (k v) (hash-table-put! memory k v)))
|
||||
(hash-for-each init-memory (lambda (k v) (hash-set! memory k v)))
|
||||
;; Search in a background thread:
|
||||
(let ([t (thread
|
||||
(lambda ()
|
||||
|
|
@ -119,7 +117,7 @@
|
|||
;; the board), the destination position, a xform inidcating how to
|
||||
;; transform the positions into canonical positions, and a number
|
||||
;; that estimates how many more steps until the end of game.
|
||||
(define-struct plan (size from-i from-j to-i to-j xform turns))
|
||||
(define-struct plan (size from-i from-j to-i to-j xform turns) #:mutable)
|
||||
|
||||
;; apply-play : board play -> board
|
||||
;; A play is (list piece from-i from-j to-i to-j turns)
|
||||
|
|
@ -254,32 +252,32 @@
|
|||
(let ([choices
|
||||
(cond
|
||||
;; Check for known win/loss at arbitrary depth:
|
||||
[(hash-table-get (config-memory config) board-key (lambda () #f))
|
||||
[(hash-ref (config-memory config) board-key (lambda () #f))
|
||||
=> (lambda (x) x)]
|
||||
;; Check for known result at specific remaining depth:
|
||||
[(hash-table-get (config-memory config) key (lambda () #f))
|
||||
[(hash-ref (config-memory config) key (lambda () #f))
|
||||
=> (lambda (x) x)]
|
||||
;; Check for immediate loss (only rating matters; plan is never used)
|
||||
[(winner? board (other me))
|
||||
(hash-table-put! (config-memory config) board-key '((-inf.0)))
|
||||
(hash-set! (config-memory config) board-key '((-inf.0)))
|
||||
'((-inf.0))]
|
||||
;; Check for immediate loss (only rating matters)
|
||||
[(winner? board me)
|
||||
(hash-table-put! (config-memory config) board-key '((+inf.0)))
|
||||
(hash-set! (config-memory config) board-key '((+inf.0)))
|
||||
'((+inf.0))]
|
||||
;; Check for depth
|
||||
[(depth . >= . (config-max-depth config))
|
||||
(set! depth-count (add1 depth-count))
|
||||
(let ([l (list
|
||||
(list ((config-rate-board config) board me last-to-i last-to-j)))])
|
||||
(hash-table-put! (config-memory config) key l)
|
||||
(hash-set! (config-memory config) key l)
|
||||
l)]
|
||||
;; Otherwise, we explore this state...
|
||||
[else
|
||||
(set! depth-count (add1 depth-count))
|
||||
(set! explore-count (add1 explore-count))
|
||||
;; In case we get back here while we're looking, claim an unknown tie:
|
||||
(hash-table-put! (config-memory config) board-key LOOP-TIE)
|
||||
(hash-set! (config-memory config) board-key LOOP-TIE)
|
||||
(let* ([choices
|
||||
(map (lambda (g)
|
||||
;; Make sure each canned move is in our coordinate system:
|
||||
|
|
@ -300,14 +298,14 @@
|
|||
'((-inf.0))
|
||||
;; We have at least one move
|
||||
choices)])
|
||||
(hash-table-remove! (config-memory config) board-key)
|
||||
(hash-remove! (config-memory config) board-key)
|
||||
(let ([key (if (and ((caar choices) . < . +inf.0)
|
||||
((caar choices) . > . -inf.0))
|
||||
;; Result is only valid to current depth limit:
|
||||
key
|
||||
;; Win or loss: result is valid to any depth:
|
||||
board-key)])
|
||||
(hash-table-put! (config-memory config) key choices)
|
||||
(hash-set! (config-memory config) key choices)
|
||||
choices))])])
|
||||
(values choices xform))))
|
||||
|
||||
|
|
@ -552,7 +550,7 @@
|
|||
(when (or (found-win? plays)
|
||||
(found-lose? plays))
|
||||
(let ([board-key+xform ((config-canonicalize config) board me)])
|
||||
(hash-table-get init-memory
|
||||
(hash-ref init-memory
|
||||
(car board-key+xform)
|
||||
(lambda ()
|
||||
;; This is new...
|
||||
|
|
@ -580,7 +578,7 @@
|
|||
(let ([v (read)])
|
||||
(unless (eof-object? v)
|
||||
(let ([board-key+xform (canonicalize (cadr v) #f)])
|
||||
(hash-table-put! init-memory
|
||||
(hash-set! init-memory
|
||||
(car board-key+xform)
|
||||
(list
|
||||
(cons (if (eq? 'win (car v)) +inf.0 -inf.0)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
(require mzlib/unitsig
|
||||
(only mzlib/unit unit import export)
|
||||
mzlib/file
|
||||
mred
|
||||
(only-in racket/unit unit import export)
|
||||
racket/file
|
||||
(except-in racket/gui define-signature provide-signature-elements)
|
||||
"sig.rkt"
|
||||
"model.rkt"
|
||||
"gui.rkt"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
(module gui mzscheme
|
||||
(module gui racket
|
||||
(require games/gl-board-game/gl-board
|
||||
mzlib/class
|
||||
mred
|
||||
mzlib/file
|
||||
racket/class
|
||||
(except-in racket/gui define-signature provide-signature-elements)
|
||||
sgl/gl-vectors
|
||||
sgl
|
||||
mzlib/unitsig
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
;; Supplies canned moves and board-rating functions for the state
|
||||
;; explorer.
|
||||
|
||||
(module heuristics mzscheme
|
||||
(module heuristics racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
"sig.rkt"
|
||||
"plays-3x3.rkt")
|
||||
|
||||
|
|
@ -19,7 +17,7 @@
|
|||
;; a perfect red player.
|
||||
(for-each (lambda (play)
|
||||
(let ([key+xform (canonicalize (list->bytes (vector->list (car play))) #f)])
|
||||
(hash-table-put! init-memory
|
||||
(hash-set! init-memory
|
||||
(car key+xform)
|
||||
(let-values ([(from-i from-j)
|
||||
(if (list-ref play 2)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module model mzscheme
|
||||
(module model racket
|
||||
(require "sig.rkt"
|
||||
mzlib/unitsig)
|
||||
|
||||
|
|
@ -26,8 +26,8 @@
|
|||
;; piece to a stack with this piece on top.
|
||||
(define-struct piece (size color gobble-table))
|
||||
|
||||
(define red-pieces (map (lambda (sz) (make-piece sz 'red (make-hash-table))) SIZES))
|
||||
(define yellow-pieces (map (lambda (sz) (make-piece sz 'yellow (make-hash-table))) SIZES))
|
||||
(define red-pieces (map (lambda (sz) (make-piece sz 'red (make-hasheq))) SIZES))
|
||||
(define yellow-pieces (map (lambda (sz) (make-piece sz 'yellow (make-hasheq))) SIZES))
|
||||
|
||||
;; Fill in stacks for pieces. By building each possible
|
||||
;; stack once, we avoid allocating redudant stacks, and
|
||||
|
|
@ -48,7 +48,7 @@
|
|||
(map (lambda (p)
|
||||
(map (lambda (stack)
|
||||
(let ([new-stack (cons p stack)])
|
||||
(hash-table-put! (piece-gobble-table p) stack new-stack)
|
||||
(hash-set! (piece-gobble-table p) stack new-stack)
|
||||
new-stack))
|
||||
prev-stacks))
|
||||
(list (car red-pieces)
|
||||
|
|
@ -134,7 +134,7 @@
|
|||
|
||||
;; gobble : piece (listof piece) -> (listof piece)
|
||||
(define (gobble p l)
|
||||
(hash-table-get (piece-gobble-table p) l))
|
||||
(hash-ref (piece-gobble-table p) l))
|
||||
|
||||
;; - - - - - - - - - - - - - - - - - -
|
||||
|
||||
|
|
@ -377,54 +377,54 @@
|
|||
(define flatten-board
|
||||
(if (= BOARD-SIZE 3)
|
||||
(lambda (board stack-ids)
|
||||
(bytes (hash-table-get stack-ids (board-ref board 0 0))
|
||||
(hash-table-get stack-ids (board-ref board 1 0))
|
||||
(hash-table-get stack-ids (board-ref board 2 0))
|
||||
(hash-table-get stack-ids (board-ref board 0 1))
|
||||
(hash-table-get stack-ids (board-ref board 1 1))
|
||||
(hash-table-get stack-ids (board-ref board 2 1))
|
||||
(hash-table-get stack-ids (board-ref board 0 2))
|
||||
(hash-table-get stack-ids (board-ref board 1 2))
|
||||
(hash-table-get stack-ids (board-ref board 2 2))))
|
||||
(bytes (hash-ref stack-ids (board-ref board 0 0))
|
||||
(hash-ref stack-ids (board-ref board 1 0))
|
||||
(hash-ref stack-ids (board-ref board 2 0))
|
||||
(hash-ref stack-ids (board-ref board 0 1))
|
||||
(hash-ref stack-ids (board-ref board 1 1))
|
||||
(hash-ref stack-ids (board-ref board 2 1))
|
||||
(hash-ref stack-ids (board-ref board 0 2))
|
||||
(hash-ref stack-ids (board-ref board 1 2))
|
||||
(hash-ref stack-ids (board-ref board 2 2))))
|
||||
(lambda (board stack-ids)
|
||||
(bytes (hash-table-get stack-ids (board-ref board 0 0))
|
||||
(hash-table-get stack-ids (board-ref board 1 0))
|
||||
(hash-table-get stack-ids (board-ref board 2 0))
|
||||
(hash-table-get stack-ids (board-ref board 3 0))
|
||||
(hash-table-get stack-ids (board-ref board 0 1))
|
||||
(hash-table-get stack-ids (board-ref board 1 1))
|
||||
(hash-table-get stack-ids (board-ref board 2 1))
|
||||
(hash-table-get stack-ids (board-ref board 3 1))
|
||||
(hash-table-get stack-ids (board-ref board 0 2))
|
||||
(hash-table-get stack-ids (board-ref board 1 2))
|
||||
(hash-table-get stack-ids (board-ref board 2 2))
|
||||
(hash-table-get stack-ids (board-ref board 3 2))
|
||||
(hash-table-get stack-ids (board-ref board 0 3))
|
||||
(hash-table-get stack-ids (board-ref board 1 3))
|
||||
(hash-table-get stack-ids (board-ref board 2 3))
|
||||
(hash-table-get stack-ids (board-ref board 3 3))))))
|
||||
(bytes (hash-ref stack-ids (board-ref board 0 0))
|
||||
(hash-ref stack-ids (board-ref board 1 0))
|
||||
(hash-ref stack-ids (board-ref board 2 0))
|
||||
(hash-ref stack-ids (board-ref board 3 0))
|
||||
(hash-ref stack-ids (board-ref board 0 1))
|
||||
(hash-ref stack-ids (board-ref board 1 1))
|
||||
(hash-ref stack-ids (board-ref board 2 1))
|
||||
(hash-ref stack-ids (board-ref board 3 1))
|
||||
(hash-ref stack-ids (board-ref board 0 2))
|
||||
(hash-ref stack-ids (board-ref board 1 2))
|
||||
(hash-ref stack-ids (board-ref board 2 2))
|
||||
(hash-ref stack-ids (board-ref board 3 2))
|
||||
(hash-ref stack-ids (board-ref board 0 3))
|
||||
(hash-ref stack-ids (board-ref board 1 3))
|
||||
(hash-ref stack-ids (board-ref board 2 3))
|
||||
(hash-ref stack-ids (board-ref board 3 3))))))
|
||||
|
||||
|
||||
;; Generate a numerical ID for each stack. This numerical
|
||||
;; ID must stay constant for all of time, because we
|
||||
;; record boards in compact form using these numbers.
|
||||
;; (For example, see "plays-3x3.rkt".)
|
||||
(define red-stack-ids (make-hash-table))
|
||||
(define yellow-stack-ids (make-hash-table))
|
||||
(define red-stack-ids (make-hasheq))
|
||||
(define yellow-stack-ids (make-hasheq))
|
||||
(for-each (lambda (s)
|
||||
(hash-table-put! red-stack-ids s (hash-table-count red-stack-ids)))
|
||||
(hash-set! red-stack-ids s (hash-count red-stack-ids)))
|
||||
all-stacks)
|
||||
(for-each (lambda (s)
|
||||
(let ([inverse
|
||||
(let loop ([s s])
|
||||
(if (null? s)
|
||||
null
|
||||
(hash-table-get (piece-gobble-table
|
||||
(hash-ref (piece-gobble-table
|
||||
(if (eq? (piece-color (car s)) 'red)
|
||||
(list-ref yellow-pieces (piece-size (car s)))
|
||||
(list-ref red-pieces (piece-size (car s)))))
|
||||
(loop (cdr s)))))])
|
||||
(hash-table-put! yellow-stack-ids s (hash-table-get red-stack-ids inverse))))
|
||||
(hash-set! yellow-stack-ids s (hash-ref red-stack-ids inverse))))
|
||||
all-stacks)
|
||||
|
||||
;; Applies an appropriate flattener
|
||||
|
|
@ -439,21 +439,21 @@
|
|||
;; xform for getting from the given board's locations to
|
||||
;; locations in the canonical board.
|
||||
(define (make-canonicalize)
|
||||
(let ([memory (make-hash-table 'equal)])
|
||||
(let ([memory (make-hash)])
|
||||
;; Convert the board into a byte string, normalizing player:
|
||||
(lambda (board who)
|
||||
(let ([v (if who
|
||||
(compact-board board who)
|
||||
board)])
|
||||
;; Find canonical mapping.
|
||||
(hash-table-get
|
||||
(hash-ref
|
||||
memory v
|
||||
(lambda ()
|
||||
(let* ([pr (cons v (car xforms))])
|
||||
(hash-table-put! memory v pr)
|
||||
(hash-set! memory v pr)
|
||||
;; Add each equivalent to table:
|
||||
(for-each (lambda (xform xform-proc)
|
||||
(hash-table-put! memory (xform-proc v) (cons v xform)))
|
||||
(hash-set! memory (xform-proc v) (cons v xform)))
|
||||
(cdr xforms) (cdr xform-procs))
|
||||
pr)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module plays-3x3 mzscheme
|
||||
(module plays-3x3 racket
|
||||
(provide 3x3-plays)
|
||||
(define 3x3-plays
|
||||
;; This list is generated by "check.rkt".
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
;; Plays automatic games, often useful when learning is enabled in "explore.rkt"
|
||||
|
||||
(module robot mzscheme
|
||||
(module robot racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
"sig.rkt"
|
||||
"model.rkt"
|
||||
"explore.rkt"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module sig mzscheme
|
||||
(module sig racket
|
||||
(require mzlib/unitsig)
|
||||
|
||||
(provide config^
|
||||
|
|
|
|||
|
|
@ -1,7 +1,5 @@
|
|||
(module test-explore mzscheme
|
||||
(module test-explore racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
"sig.rkt"
|
||||
"model.rkt"
|
||||
"explore.rkt"
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
;; Some tests for the model
|
||||
|
||||
(module test-model mzscheme
|
||||
(module test-model racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/etc
|
||||
mzlib/list
|
||||
"sig.rkt"
|
||||
"model.rkt"
|
||||
"test.rkt")
|
||||
|
||||
;; Test basic procs:
|
||||
(define (test-folding n)
|
||||
(begin-with-definitions
|
||||
|
||||
(define BOARD-SIZE n)
|
||||
(define-values/invoke-unit/sig model^
|
||||
model-unit #f config^)
|
||||
|
|
@ -32,13 +30,12 @@
|
|||
(lambda (a b)
|
||||
(if (= (car a) (car b))
|
||||
(< (cdr a) (cdr b))
|
||||
(< (car a) (car b))))))))
|
||||
(< (car a) (car b)))))))
|
||||
(test-folding 3)
|
||||
(test-folding 4)
|
||||
|
||||
;; Test available-off-board for 3x3:
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
(define BOARD-SIZE 3)
|
||||
(define-values/invoke-unit/sig model^
|
||||
model-unit #f config^)
|
||||
|
|
@ -53,11 +50,11 @@
|
|||
(test '((2 2) (1) (0 0)) (available-off-board b3 'yellow))
|
||||
(let ([b4 (move b3 (list-ref red-pieces 2) #f #f 0 1 values void)])
|
||||
(test '((1 1) (0 0)) (available-off-board b4 'red))
|
||||
(test '((2 2) (1) (0 0)) (available-off-board b4 'yellow)))))))
|
||||
(test '((2 2) (1) (0 0)) (available-off-board b4 'yellow))))))
|
||||
|
||||
;; Test available-off-board for 4x4:
|
||||
(let ()
|
||||
(begin-with-definitions
|
||||
|
||||
(define BOARD-SIZE 4)
|
||||
(define-values/invoke-unit/sig model^
|
||||
model-unit #f config^)
|
||||
|
|
@ -78,16 +75,16 @@
|
|||
(let ([b5 (move b4 (list-ref red-pieces 3) #f #f 0 3 values void)])
|
||||
(test '((3 2 1 0) (2 1 0) (1 0)) (available-off-board b5 'red))
|
||||
(let ([b6 (move b5 (list-ref red-pieces 2) #f #f 3 3 values void)])
|
||||
(test '((3 2 1 0) (1 0) (1 0)) (available-off-board b6 'red)))))))))
|
||||
(test '((3 2 1 0) (1 0) (1 0)) (available-off-board b6 'red))))))))
|
||||
|
||||
(define x-table (make-hash-table 'equal))
|
||||
(define x-table (make-hash))
|
||||
(define (testx id board)
|
||||
(test id (hash-table-get x-table board
|
||||
(test id (hash-ref x-table board
|
||||
(lambda ()
|
||||
(when (hash-table-get x-table id (lambda () #f))
|
||||
(when (hash-ref x-table id (lambda () #f))
|
||||
(error 'testx "id already mapped\n"))
|
||||
(hash-table-put! x-table id #t)
|
||||
(hash-table-put! x-table board id)
|
||||
(hash-set! x-table id #t)
|
||||
(hash-set! x-table board id)
|
||||
id))))
|
||||
|
||||
;; Given a canonicalize function, a board, the current player,
|
||||
|
|
@ -153,7 +150,7 @@
|
|||
(car key+xform)))
|
||||
|
||||
;; Test canonicalization, 3x3
|
||||
(begin-with-definitions
|
||||
(let ()
|
||||
(define BOARD-SIZE 3)
|
||||
(define-values/invoke-unit/sig model^
|
||||
model-unit #f config^)
|
||||
|
|
@ -185,10 +182,10 @@
|
|||
(testx 27 (c b5 'red))
|
||||
(testx 35 (c b5 'yellow)))))))))
|
||||
|
||||
(set! x-table (make-hash-table 'equal))
|
||||
(set! x-table (make-hash))
|
||||
|
||||
;; Test canonicalization, 4x4
|
||||
(begin-with-definitions
|
||||
|
||||
(define BOARD-SIZE 4)
|
||||
(define-values/invoke-unit/sig model^
|
||||
model-unit #f config^)
|
||||
|
|
@ -213,7 +210,7 @@
|
|||
(testx 13 (c b2 'yellow))
|
||||
(let ([b3 (move b2 (list-ref yellow-pieces 1) #f #f 1 0 values void)])
|
||||
(testx 17 (c b3 'red))
|
||||
(testx 25 (c b3 'yellow))))))))
|
||||
(testx 25 (c b3 'yellow)))))))
|
||||
|
||||
(define (basic-tests size xform 4x4-finish-pos)
|
||||
;; When xform is the identity, then we build toward
|
||||
|
|
@ -223,7 +220,7 @@
|
|||
;; - - - -
|
||||
;; The xform changes the cooridnate system so that we
|
||||
;; test rows and columns in addition to this diagonal.
|
||||
(begin-with-definitions
|
||||
|
||||
(define BOARD-SIZE size)
|
||||
|
||||
(define-values (i00 j00) (xform 0 0))
|
||||
|
|
@ -359,7 +356,7 @@
|
|||
4x4-finish-pos)
|
||||
;; 4 x 4 game: now red can cover small yellow, because it's
|
||||
;; part of 3 in a row
|
||||
(begin-with-definitions
|
||||
|
||||
(test #t (3-in-a-row? b7.2 i20 j20 'yellow))
|
||||
(test #f (3-in-a-row? b7.2 i20 j20 'red))
|
||||
|
||||
|
|
@ -375,7 +372,7 @@
|
|||
|
||||
(define b8.2x (move b7.2 med-yellow #f #f (car 4x4-finish-pos) (cdr 4x4-finish-pos) values void))
|
||||
(test #f (winner? b8.2x 'red))
|
||||
(test #t (winner? b8.2x 'yellow))))))
|
||||
(test #t (winner? b8.2x 'yellow))))
|
||||
|
||||
(define (rotate i j)
|
||||
(case i
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
(module test mzscheme
|
||||
(module test racket
|
||||
(provide test report-test-results)
|
||||
|
||||
(define failed? #f)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang mzscheme
|
||||
(require games/cards mred mzlib/class mzlib/unit mzlib/list)
|
||||
#lang racket
|
||||
(require games/cards racket/gui racket/class racket/unit)
|
||||
|
||||
(provide game@)
|
||||
(define game@ (unit (import) (export)
|
||||
|
|
@ -7,7 +7,7 @@
|
|||
;; Player record
|
||||
(define-struct player (r hand-r discard-r count-r ; regions
|
||||
hand discarded ; cards
|
||||
tried)) ; memory for simulating players
|
||||
tried) #:mutable) ; memory for simulating players
|
||||
|
||||
;; Player names
|
||||
(define PLAYER-1-NAME "Opponent 1")
|
||||
|
|
|
|||
|
|
@ -2,5 +2,5 @@
|
|||
|
||||
(define scribblings '(("scribblings/games.scrbl" (multi-page) (gui-library))))
|
||||
|
||||
(define mred-launcher-libraries (list "main.rkt"))
|
||||
(define mred-launcher-names (list "PLT Games"))
|
||||
(define racket-gui-launcher-libraries (list "main.rkt"))
|
||||
(define racket-gui-launcher-names (list "PLT Games"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
; -*- Scheme -*-
|
||||
|
||||
(module array mzscheme
|
||||
(module array racket
|
||||
|
||||
(provide array-make array-ref array-set!
|
||||
array-mult array-mult-vector
|
||||
|
|
@ -89,7 +89,7 @@
|
|||
(do ((i 1 (+ i 1))) ((= i n))
|
||||
(set! j2 0)
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(if (not (= j j1))
|
||||
(when (not (= j j1))
|
||||
(begin
|
||||
(array-set! m (- i 1) j2 (array-ref a i j))
|
||||
(set! j2 (+ j2 1))
|
||||
|
|
@ -120,11 +120,11 @@
|
|||
(jj 0)
|
||||
)
|
||||
(do ((i 0 (+ i 1))) ((= i n))
|
||||
(if (not (= i in))
|
||||
(when (not (= i in))
|
||||
(begin
|
||||
(set! jj 0)
|
||||
(do ((j 0 (+ j 1))) ((= j n))
|
||||
(if (not (= j jn))
|
||||
(when (not (= j jn))
|
||||
(begin
|
||||
(array-set! m ii jj (array-ref a i j))
|
||||
(set! jj (+ jj 1))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define game "jewel.scm")
|
||||
(define game "jewel.rkt")
|
||||
(define game-set "Puzzle Games")
|
||||
|
|
|
|||
|
|
@ -1,20 +1,19 @@
|
|||
; FIXME:
|
||||
; - object rotation axis could be random per type
|
||||
|
||||
(module jewel mzscheme
|
||||
(module jewel racket
|
||||
|
||||
(require mzlib/unit
|
||||
mzlib/string
|
||||
mzlib/class
|
||||
mzlib/file
|
||||
mred
|
||||
(require racket/unit
|
||||
racket/class
|
||||
racket/file
|
||||
racket/gui
|
||||
sgl/gl
|
||||
sgl/gl-vectors
|
||||
(only sgl/sgl get-gl-version-number)
|
||||
"shapes.scm"
|
||||
"array.scm"
|
||||
"text.scm"
|
||||
"../show-scribbling.ss"
|
||||
(only-in sgl/sgl get-gl-version-number)
|
||||
"shapes.rkt"
|
||||
"array.rkt"
|
||||
"text.rkt"
|
||||
"../show-scribbling.rkt"
|
||||
)
|
||||
|
||||
(provide game@)
|
||||
|
|
@ -189,7 +188,7 @@
|
|||
( (or (eq? c #\h) (eq? c #\H))
|
||||
(show-jewel-help) )
|
||||
( (or (eq? c #\p) (eq? c #\P))
|
||||
(if (equal? gamestate 'PLAYING)
|
||||
(when (equal? gamestate 'PLAYING)
|
||||
(begin
|
||||
(set! freeze (not freeze))
|
||||
(if freeze
|
||||
|
|
@ -285,7 +284,7 @@
|
|||
(define/override (on-paint)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(if (and initialised expose)
|
||||
(when (and initialised expose)
|
||||
(expose)
|
||||
)
|
||||
(swap-gl-buffers)
|
||||
|
|
@ -296,7 +295,7 @@
|
|||
(define/override (on-size width height)
|
||||
(with-gl-context
|
||||
(lambda ()
|
||||
(if (not initialised)
|
||||
(when (not initialised)
|
||||
(begin
|
||||
(realize)
|
||||
(set! initialised #t)
|
||||
|
|
@ -339,49 +338,49 @@
|
|||
(move (vector-ref move-db (+ iy 2)))
|
||||
(type (random 7))
|
||||
)
|
||||
(hash-table-put! elem 'type type )
|
||||
(hash-table-put! elem 'angle (random 360) )
|
||||
(hash-table-put! elem 'ax 0.0 )
|
||||
(hash-table-put! elem 'ay 1.0 )
|
||||
(hash-table-put! elem 'az 0.0 )
|
||||
(hash-table-put! elem 'fall 0.0 )
|
||||
(hash-table-put! elem 'speed 0.0 )
|
||||
(hash-table-put! elem 'vanish 1.0 )
|
||||
(hash-table-put! elem 'dx 0.0 )
|
||||
(hash-table-put! elem 'dy 0.0 )
|
||||
(hash-table-put! elem 'swapping 0 )
|
||||
(hash-set! elem 'type type )
|
||||
(hash-set! elem 'angle (random 360) )
|
||||
(hash-set! elem 'ax 0.0 )
|
||||
(hash-set! elem 'ay 1.0 )
|
||||
(hash-set! elem 'az 0.0 )
|
||||
(hash-set! elem 'fall 0.0 )
|
||||
(hash-set! elem 'speed 0.0 )
|
||||
(hash-set! elem 'vanish 1.0 )
|
||||
(hash-set! elem 'dx 0.0 )
|
||||
(hash-set! elem 'dy 0.0 )
|
||||
(hash-set! elem 'swapping 0 )
|
||||
|
||||
(cond
|
||||
; one color per type
|
||||
; one shape for all type
|
||||
( (= jewel-difficulty 1)
|
||||
(hash-table-put! elem 'color type)
|
||||
(hash-table-put! elem 'shape diff-shape)
|
||||
(hash-set! elem 'color type)
|
||||
(hash-set! elem 'shape diff-shape)
|
||||
)
|
||||
; one color for all type
|
||||
; one shape per type
|
||||
( (= jewel-difficulty 2)
|
||||
(hash-table-put! elem 'color diff-color)
|
||||
(hash-table-put! elem 'shape type)
|
||||
(hash-set! elem 'color diff-color)
|
||||
(hash-set! elem 'shape type)
|
||||
)
|
||||
; one color per type
|
||||
; random shape
|
||||
( (= jewel-difficulty 3)
|
||||
(hash-table-put! elem 'color type)
|
||||
(hash-table-put! elem 'shape (random 7))
|
||||
(hash-set! elem 'color type)
|
||||
(hash-set! elem 'shape (random 7))
|
||||
)
|
||||
; random color
|
||||
; one shape per type
|
||||
( (= jewel-difficulty 4)
|
||||
(hash-table-put! elem 'color (random 7))
|
||||
(hash-table-put! elem 'shape type)
|
||||
(hash-set! elem 'color (random 7))
|
||||
(hash-set! elem 'shape type)
|
||||
)
|
||||
; default
|
||||
; one color per type
|
||||
; one shape per type
|
||||
( else
|
||||
(hash-table-put! elem 'color type)
|
||||
(hash-table-put! elem 'shape type)
|
||||
(hash-set! elem 'color type)
|
||||
(hash-set! elem 'shape type)
|
||||
)
|
||||
)
|
||||
|
||||
|
|
@ -406,7 +405,7 @@
|
|||
(vector-set! element-db iy row)
|
||||
(do ((ix 0 (+ ix 1))) ((= ix ex))
|
||||
(let*
|
||||
( (elem (make-hash-table 'equal)) )
|
||||
( (elem (make-hash)) )
|
||||
(vector-set! row ix elem)
|
||||
(element-init iy ix)
|
||||
)
|
||||
|
|
@ -417,7 +416,7 @@
|
|||
|
||||
|
||||
(define (element-get iy ix prop)
|
||||
(hash-table-get (vector-ref (vector-ref element-db iy) ix)
|
||||
(hash-ref (vector-ref (vector-ref element-db iy) ix)
|
||||
prop (lambda () #f))
|
||||
)
|
||||
|
||||
|
|
@ -425,7 +424,7 @@
|
|||
(define (element-set! iy ix prop value)
|
||||
(let*
|
||||
( (elem (vector-ref (vector-ref element-db iy) ix)) )
|
||||
(hash-table-put! elem prop value)
|
||||
(hash-set! elem prop value)
|
||||
)
|
||||
)
|
||||
|
||||
|
|
@ -455,9 +454,9 @@
|
|||
( (elem1 (vector-ref (vector-ref element-db iy) ix))
|
||||
(elem2 (vector-ref (vector-ref element-db jy) jx))
|
||||
)
|
||||
(hash-table-for-each
|
||||
(hash-for-each
|
||||
elem1
|
||||
(lambda (key val) (hash-table-put! elem2 key val))
|
||||
(lambda (key val) (hash-set! elem2 key val))
|
||||
)
|
||||
; move array
|
||||
(array-set! move-db (+ jy 2) (+ jx 2)
|
||||
|
|
@ -470,38 +469,38 @@
|
|||
; score number handling functions
|
||||
; -----------------------------------------------------------------
|
||||
|
||||
(define score-numbers (make-hash-table 'equal))
|
||||
(define score-numbers (make-hash))
|
||||
(define score-key 0)
|
||||
(define score-fade 0.01)
|
||||
|
||||
(define (score-add x y z fade value)
|
||||
(let*
|
||||
( (elem (make-hash-table 'equal)) )
|
||||
(hash-table-put! elem 'x x)
|
||||
(hash-table-put! elem 'y y)
|
||||
(hash-table-put! elem 'z z)
|
||||
(hash-table-put! elem 'fade fade)
|
||||
(hash-table-put! elem 'value value)
|
||||
( (elem (make-hash)) )
|
||||
(hash-set! elem 'x x)
|
||||
(hash-set! elem 'y y)
|
||||
(hash-set! elem 'z z)
|
||||
(hash-set! elem 'fade fade)
|
||||
(hash-set! elem 'value value)
|
||||
|
||||
(hash-table-put! score-numbers score-key elem)
|
||||
(hash-set! score-numbers score-key elem)
|
||||
(set! score-key (+ score-key 1))
|
||||
)
|
||||
)
|
||||
|
||||
(define (score-set! elem prop val)
|
||||
(hash-table-put! elem prop val)
|
||||
(hash-set! elem prop val)
|
||||
)
|
||||
|
||||
(define (score-del! score-key)
|
||||
(hash-table-remove! score-numbers score-key)
|
||||
(hash-remove! score-numbers score-key)
|
||||
)
|
||||
|
||||
(define (score-get elem prop)
|
||||
(hash-table-get elem prop)
|
||||
(hash-ref elem prop)
|
||||
)
|
||||
|
||||
(define (score-for-each proc table)
|
||||
(hash-table-for-each
|
||||
(hash-for-each
|
||||
table
|
||||
(lambda (key val) (proc key val))
|
||||
)
|
||||
|
|
@ -528,9 +527,9 @@
|
|||
) )
|
||||
(set! idx (- idx 1))
|
||||
)
|
||||
(if (>= idx 0)
|
||||
(when (>= idx 0)
|
||||
(begin
|
||||
(if (or empty
|
||||
(when (or empty
|
||||
(and (not empty) (> (- last idx) 0)) )
|
||||
(set! slist (cons (substring str idx last) slist))
|
||||
)
|
||||
|
|
@ -581,7 +580,7 @@
|
|||
|
||||
(do ((i 0 (+ i 1))) ((or exit? (= i (vector-length high-scores))))
|
||||
(set! score (vector-ref high-scores i))
|
||||
(if (> jewel-score (string->number (list-ref score 1)))
|
||||
(when (> jewel-score (string->number (list-ref score 1)))
|
||||
(begin
|
||||
(do ((j (- (vector-length high-scores) 1) (- j 1)))
|
||||
((= j i))
|
||||
|
|
@ -709,7 +708,7 @@
|
|||
(do ((i 0 (+ i 1))) ((= i (vector-length levels)))
|
||||
(glTranslatef 0.0 -1.8 0.0)
|
||||
(glPushMatrix)
|
||||
(if (= (remainder i 2) 0)
|
||||
(when (= (remainder i 2) 0)
|
||||
(string-draw (number->string (/ i 2)) )
|
||||
)
|
||||
(glTranslatef highxname 0.0 0.0)
|
||||
|
|
@ -757,7 +756,7 @@
|
|||
(set! jewel-score 0)
|
||||
(set! jewel-level 0)
|
||||
(set! jewel-nmoves 0)
|
||||
(set! score-numbers (make-hash-table 'equal))
|
||||
(set! score-numbers (make-hash))
|
||||
|
||||
(set! gamestate 'GAME-OVER)
|
||||
;read high scores
|
||||
|
|
@ -895,10 +894,10 @@
|
|||
(do ((iy (- ey 1) (- iy 1))) ((< iy 0))
|
||||
(do ((ix 0 (+ ix 1))) ((= ix ex))
|
||||
|
||||
(if (= (element-get iy ix 'vanish) 0.0)
|
||||
(when (= (element-get iy ix 'vanish) 0.0)
|
||||
(let ( (finished -1) )
|
||||
(do ((k (- iy 1) (- k 1))) ((or (< k 0) (> finished -1)))
|
||||
(if (not (= (element-get k ix 'vanish) 0.0))
|
||||
(when (not (= (element-get k ix 'vanish) 0.0))
|
||||
(set! finished k)
|
||||
)
|
||||
)
|
||||
|
|
@ -935,7 +934,7 @@
|
|||
(set! jewel-score (+ jewel-score value))
|
||||
(set! jewel-stage (+ jewel-stage len))
|
||||
(set! jewel-life (+ jewel-life (* value credit)))
|
||||
(if (>= jewel-stage nextlevel)
|
||||
(when (>= jewel-stage nextlevel)
|
||||
(begin
|
||||
(set! jewel-stage (- jewel-stage nextlevel))
|
||||
(set! jewel-level (+ jewel-level 1))
|
||||
|
|
@ -949,7 +948,7 @@
|
|||
(define (declife)
|
||||
(unless (eq? gamestate 'GAME-OVER)
|
||||
(set! jewel-life (- jewel-life jewel-decay))
|
||||
(if (< jewel-life 0.0)
|
||||
(when (< jewel-life 0.0)
|
||||
(let* ( (score #f) (exit? #f) )
|
||||
; set life points to zero
|
||||
(set! jewel-life 0.0)
|
||||
|
|
@ -981,7 +980,7 @@
|
|||
(if (>= identical 3)
|
||||
(begin
|
||||
(set! hadsome #t)
|
||||
(if (not checking)
|
||||
(when (not checking)
|
||||
(let*
|
||||
( (x (- ix 1 (/ identical 2.0)))
|
||||
(y (+ iy 0.5))
|
||||
|
|
@ -1017,7 +1016,7 @@
|
|||
(if (>= identical 3)
|
||||
(begin
|
||||
(set! hadsome #t)
|
||||
(if (not checking)
|
||||
(when (not checking)
|
||||
(let*
|
||||
( (x ix)
|
||||
(y (- iy 0.5 (/ identical 2.0)))
|
||||
|
|
@ -1077,7 +1076,7 @@
|
|||
; check for all combination
|
||||
(do ((iy 0 (+ iy 1))) ((= iy ey))
|
||||
(do ((ix 0 (+ ix 1))) ((= ix ex))
|
||||
(if (not (= (element-get iy ix 'type)
|
||||
(when (not (= (element-get iy ix 'type)
|
||||
(array-ref move-db (+ iy 2) (+ ix 2))))
|
||||
(begin
|
||||
(display "wrong iy: ")(display iy)
|
||||
|
|
@ -1087,7 +1086,7 @@
|
|||
; all 16, possible combinations
|
||||
(do ((k 0 (+ k 1))) ((= k 16))
|
||||
(set! type (array-ref move-db (+ iy 2) (+ ix 2)))
|
||||
(if (and (= type (array-ref move-db
|
||||
(when (and (= type (array-ref move-db
|
||||
(+ iy 2 (array-ref chkpos k 1))
|
||||
(+ ix 2 (array-ref chkpos k 0))))
|
||||
(= type (array-ref move-db
|
||||
|
|
@ -1144,7 +1143,7 @@
|
|||
|
||||
(case action-mode
|
||||
( (ACTION-LOOKING)
|
||||
(if (equal? gamestate 'PLAYING)
|
||||
(when (equal? gamestate 'PLAYING)
|
||||
(if (findwins #f)
|
||||
(set! action-mode 'ACTION-REMOVING)
|
||||
; check if any move is possible at all ???
|
||||
|
|
@ -1167,17 +1166,17 @@
|
|||
)
|
||||
)
|
||||
( (ACTION-WAITING)
|
||||
(if (equal? gamestate 'PLAYING)
|
||||
(when (equal? gamestate 'PLAYING)
|
||||
(begin
|
||||
(declife)
|
||||
(if tryswap?
|
||||
(when tryswap?
|
||||
(set! action-mode 'ACTION-SWAPPING)
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
( (ACTION-SWAPPING ACTION-UNSWAPPING)
|
||||
(if (equal? action-mode 'ACTION-UNSWAPPING)
|
||||
(when (equal? action-mode 'ACTION-UNSWAPPING)
|
||||
(declife)
|
||||
)
|
||||
(set! tryswap? #f)
|
||||
|
|
@ -1188,7 +1187,7 @@
|
|||
(do ((iy 0 (+ iy 1))) ((= iy ey))
|
||||
(do ((ix 0 (+ ix 1))) ((= ix ex))
|
||||
(set! swap (element-get iy ix 'swapping))
|
||||
(if (not (= swap 0))
|
||||
(when (not (= swap 0))
|
||||
(begin
|
||||
(set! hadsome 1)
|
||||
(set! swap (+ swap 1))
|
||||
|
|
@ -1210,7 +1209,7 @@
|
|||
)
|
||||
)
|
||||
|
||||
(if (= hadsome 2)
|
||||
(when (= hadsome 2)
|
||||
(cond
|
||||
( (findwins #f)
|
||||
(set! locked? #f)
|
||||
|
|
@ -1248,7 +1247,7 @@
|
|||
(do ((iy 0 (+ iy 1))) ((= iy ey))
|
||||
(do ((ix 0 (+ ix 1))) ((= ix ex))
|
||||
(set! vanish (element-get iy ix 'vanish))
|
||||
(if (< vanish 1.0)
|
||||
(when (< vanish 1.0)
|
||||
(begin
|
||||
(set! vanish (- vanish vanishrate))
|
||||
(if (< vanish 0.0)
|
||||
|
|
@ -1262,7 +1261,7 @@
|
|||
)
|
||||
)
|
||||
)
|
||||
(if (> hadsome 0)
|
||||
(when (> hadsome 0)
|
||||
(begin
|
||||
(replace)
|
||||
(set! action-mode 'ACTION-DROPPING)
|
||||
|
|
@ -1281,7 +1280,7 @@
|
|||
(do ((iy 0 (+ iy 1))) ((= iy ey))
|
||||
(do ((ix 0 (+ ix 1))) ((= ix ex))
|
||||
(set! fall (element-get iy ix 'fall))
|
||||
(if (> fall 0.0)
|
||||
(when (> fall 0.0)
|
||||
(begin
|
||||
(set! hadsome (+ hadsome 1))
|
||||
(set! fall (- fall (element-get iy ix 'speed)))
|
||||
|
|
@ -1298,7 +1297,7 @@
|
|||
)
|
||||
)
|
||||
)
|
||||
(if (= hadsome 0)
|
||||
(when (= hadsome 0)
|
||||
(set! action-mode 'ACTION-LOOKING)
|
||||
)
|
||||
); end of let
|
||||
|
|
@ -1411,7 +1410,7 @@
|
|||
(glLightfv GL_LIGHT1 GL_POSITION (vector->gl-float-vector light1pos))
|
||||
(glLightfv GL_LIGHT2 GL_POSITION (vector->gl-float-vector light2pos))
|
||||
|
||||
(if (equal? gamestate 'PLAYING)
|
||||
(when (equal? gamestate 'PLAYING)
|
||||
(show-life)
|
||||
)
|
||||
|
||||
|
|
@ -1443,7 +1442,7 @@
|
|||
(set! nx (+ x shiftx))
|
||||
(set! ny y)
|
||||
(set! nz (* (- 1.0 (element-get iy ix 'vanish)) 50.0))
|
||||
(if (not (= (element-get iy ix 'swapping) 0))
|
||||
(when (not (= (element-get iy ix 'swapping) 0))
|
||||
(begin
|
||||
(set! ang (/ (* (element-get iy ix 'swapping) 3.1415927)
|
||||
2.0
|
||||
|
|
@ -1452,7 +1451,7 @@
|
|||
(set! nx (+ nx (* s (element-get iy ix 'dx))))
|
||||
(set! ny (+ ny (* s (element-get iy ix 'dy))))
|
||||
(set! s (* t (sin (* ang 2.0))))
|
||||
(if (= (remainder counter 2) 1)
|
||||
(when (= (remainder counter 2) 1)
|
||||
(set! s (- s))
|
||||
)
|
||||
(set! counter (+ counter 1))
|
||||
|
|
@ -1466,7 +1465,7 @@
|
|||
(set! yt ny)
|
||||
(set! zt nz)
|
||||
|
||||
(if (and (equal? gamestate 'PLAYING)
|
||||
(when (and (equal? gamestate 'PLAYING)
|
||||
(= cposx ix) (= cposy iy))
|
||||
(begin
|
||||
(glEnable GL_LIGHT2)
|
||||
|
|
@ -1484,7 +1483,7 @@
|
|||
|
||||
(glPopMatrix)
|
||||
|
||||
(if (and (equal? gamestate 'PLAYING)
|
||||
(when (and (equal? gamestate 'PLAYING)
|
||||
(= cposx ix) (= cposy iy))
|
||||
(glDisable GL_LIGHT2)
|
||||
)
|
||||
|
|
@ -1589,11 +1588,11 @@
|
|||
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE
|
||||
(vector->gl-float-vector (vector-ref color-map 6)))
|
||||
; if not playing cover with dim square
|
||||
(if (equal? gamestate 'GAME-OVER)
|
||||
(when (equal? gamestate 'GAME-OVER)
|
||||
(high-score-render)
|
||||
)
|
||||
|
||||
(if (equal? gamestate 'DIFFICULTY)
|
||||
(when (equal? gamestate 'DIFFICULTY)
|
||||
(difficulty-render)
|
||||
)
|
||||
)
|
||||
|
|
@ -1729,7 +1728,7 @@
|
|||
; we are playing,
|
||||
; no action is happening
|
||||
; and mouse is moved, so try to swap
|
||||
(if (and isdown?
|
||||
(when (and isdown?
|
||||
(equal? gamestate 'PLAYING)
|
||||
(equal? action-mode 'ACTION-WAITING)
|
||||
(> (+ (* dx dx) (* dy dy)) (* dist dist))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
(module shapes mzscheme
|
||||
(module shapes racket
|
||||
|
||||
(require sgl/gl
|
||||
sgl/gl-vectors
|
||||
|
|
@ -413,7 +413,7 @@
|
|||
(glBegin GL_QUAD_STRIP)
|
||||
(do ((i 0 (+ i 1))) ((= i (+ csides 1)))
|
||||
(set! cur (if (< i csides) i (- i csides)))
|
||||
(if (> i 0)
|
||||
(when (> i 0)
|
||||
(glNormal3f (/ (+ (vector-ref x cur)
|
||||
(vector-ref x prev)) 2.0)
|
||||
0.0
|
||||
|
|
@ -463,7 +463,7 @@
|
|||
(glBegin GL_QUAD_STRIP)
|
||||
(do ((j 0 (+ j 1))) ((= j (+ usides 1)))
|
||||
(set! t (if (< j usides) j (- j usides)))
|
||||
(if (not (= j 0))
|
||||
(when (not (= j 0))
|
||||
(let*
|
||||
( (c #f) (s #f) )
|
||||
(set! a (/ (* (+ i 0.5) 3.1415927) vsides))
|
||||
|
|
@ -525,10 +525,10 @@
|
|||
(set! s (/ d h))
|
||||
(do ((i 0 (+ i 1))) ((= i (+ dsides 1)))
|
||||
(set! j (if (< i dsides) i (- i dsides)))
|
||||
(if (= t 0)
|
||||
(when (= t 0)
|
||||
(set! j (- dsides 1 j))
|
||||
)
|
||||
(if (> i 0)
|
||||
(when (> i 0)
|
||||
(glNormal3f (* (/ (+ (vector-ref x j)
|
||||
(vector-ref x o)) 2.0) s)
|
||||
(* size c)
|
||||
|
|
@ -673,7 +673,7 @@
|
|||
|
||||
(do ((i 0 (+ i 1))) ((= i spikes))
|
||||
(set! j (+ i 1))
|
||||
(if (>= j spikes)
|
||||
(when (>= j spikes)
|
||||
(set! j (- j spikes))
|
||||
)
|
||||
|
||||
|
|
@ -713,7 +713,7 @@
|
|||
|
||||
(do ((i 0 (+ i 1))) ((= i spikes))
|
||||
(set! j (+ i 1))
|
||||
(if (>= j spikes)
|
||||
(when (>= j spikes)
|
||||
(set! j (- j spikes))
|
||||
)
|
||||
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
(module text mzscheme
|
||||
(module text racket
|
||||
|
||||
(require mred
|
||||
mzlib/class
|
||||
(require racket
|
||||
racket/class
|
||||
sgl/gl
|
||||
sgl/gl-vectors
|
||||
)
|
||||
|
|
@ -59,7 +59,7 @@
|
|||
|
||||
|
||||
; font database is a hash table
|
||||
(define font-db (make-hash-table 'equal))
|
||||
(define font-db (make-hash))
|
||||
(define font-gen #f)
|
||||
(define font-scale #f)
|
||||
|
||||
|
|
@ -122,7 +122,7 @@
|
|||
(set! width (interpret-hershey (cadr elem) scale))
|
||||
(glEndList)
|
||||
|
||||
(hash-table-put! font-db (car elem) (cons i width))
|
||||
(hash-set! font-db (car elem) (cons i width))
|
||||
)
|
||||
)
|
||||
)
|
||||
|
|
@ -132,13 +132,13 @@
|
|||
(let*
|
||||
( (n (string-length str))
|
||||
(c #f) (e #f)
|
||||
(star (hash-table-get font-db #\*))
|
||||
(star (hash-ref font-db #\*))
|
||||
)
|
||||
(glPushMatrix)
|
||||
(glNormal3f 0.0 0.0 1.0)
|
||||
(do ((i 0 (+ i 1))) ((= i n))
|
||||
(set! c (string-ref str i))
|
||||
(set! e (hash-table-get font-db c (lambda () star) ))
|
||||
(set! e (hash-ref font-db c (lambda () star) ))
|
||||
(glCallList (+ font-gen (car e)))
|
||||
(glTranslatef (* font-scale (cdr e)) 0.0 0.0)
|
||||
)
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
(module board mzscheme
|
||||
(require mred
|
||||
mzlib/class
|
||||
mzlib/etc
|
||||
(module board racket
|
||||
(require racket/gui
|
||||
racket/class
|
||||
"boards.rkt")
|
||||
|
||||
(provide
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
(require "board.rkt"
|
||||
"../show-scribbling.rkt"
|
||||
mred
|
||||
mzlib/class
|
||||
mzlib/unit)
|
||||
racket/gui
|
||||
racket/class
|
||||
racket/unit)
|
||||
|
||||
(provide game@ lights-out^)
|
||||
|
||||
|
|
|
|||
BIN
collects/games/main
Executable file
BIN
collects/games/main
Executable file
Binary file not shown.
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/gui
|
||||
|
||||
(require setup/getinfo mrlib/bitmap-label "show-help.rkt")
|
||||
(require setup/getinfo "show-help.rkt")
|
||||
|
||||
(define-struct game (file name set icon))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang mzscheme
|
||||
(require games/cards mred mzlib/class mzlib/unit mzlib/list)
|
||||
#lang racket
|
||||
(require games/cards racket/gui racket/class racket/unit)
|
||||
|
||||
(provide game@)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
|
||||
(module gen-tiles mzscheme
|
||||
(require mzlib/class
|
||||
mred
|
||||
mzlib/math)
|
||||
(module gen-tiles racket
|
||||
(require racket/gui
|
||||
racket/math)
|
||||
|
||||
(define SIZE 24)
|
||||
|
||||
|
|
|
|||
Binary file not shown.
|
Before Width: | Height: | Size: 446 B After Width: | Height: | Size: 567 B |
Binary file not shown.
|
Before Width: | Height: | Size: 806 B After Width: | Height: | Size: 923 B |
Binary file not shown.
|
Before Width: | Height: | Size: 349 B After Width: | Height: | Size: 345 B |
Binary file not shown.
|
Before Width: | Height: | Size: 454 B After Width: | Height: | Size: 478 B |
Binary file not shown.
|
Before Width: | Height: | Size: 398 B After Width: | Height: | Size: 429 B |
Binary file not shown.
|
Before Width: | Height: | Size: 422 B After Width: | Height: | Size: 460 B |
Binary file not shown.
|
Before Width: | Height: | Size: 454 B After Width: | Height: | Size: 482 B |
Binary file not shown.
|
Before Width: | Height: | Size: 455 B After Width: | Height: | Size: 490 B |
|
|
@ -3,12 +3,9 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;; Configuration ;;;;;;;;;;;;;;;;;;
|
||||
|
||||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require mzlib/etc ; defines build-vector
|
||||
mzlib/class
|
||||
mzlib/unit
|
||||
mred
|
||||
(require racket/gui
|
||||
mrlib/include-bitmap)
|
||||
|
||||
(provide game@)
|
||||
|
|
@ -207,7 +204,7 @@
|
|||
[on-close ; stop the timer, in case it's running
|
||||
(lambda ()
|
||||
(send board-canvas stop-timer)
|
||||
(inner () on-close))])
|
||||
(inner '() on-close))])
|
||||
(super-instantiate ()))
|
||||
("Minesweeper")
|
||||
[style '(no-resize-border metal)]))
|
||||
|
|
@ -264,7 +261,7 @@
|
|||
(set! start-time (current-seconds))
|
||||
(set! timer
|
||||
(make-object
|
||||
(class timer% ()
|
||||
(class timer% '()
|
||||
(override*
|
||||
[notify
|
||||
(lambda ()
|
||||
|
|
|
|||
|
|
@ -1,11 +1,9 @@
|
|||
(module all-problems mzscheme
|
||||
(require mzlib/etc
|
||||
mzlib/list
|
||||
mzlib/unitsig
|
||||
(module all-problems racket
|
||||
(require mzlib/unitsig
|
||||
mzlib/include
|
||||
"problem.rkt")
|
||||
|
||||
(require-for-syntax mzlib/etc)
|
||||
|
||||
|
||||
(define-signature paint-by-numbers:all-problems^ (problemss set-names))
|
||||
(define-signature paint-by-numbers:problem-set^ (problems set-name))
|
||||
|
|
|
|||
|
|
@ -36,10 +36,9 @@ paint by numbers.
|
|||
|
||||
|#
|
||||
|
||||
(require mred
|
||||
(require racket/gui
|
||||
framework
|
||||
mzlib/etc
|
||||
mzlib/class)
|
||||
racket/class)
|
||||
|
||||
(provide paint-by-numbers-canvas%
|
||||
design-paint-by-numbers-canvas%)
|
||||
|
|
|
|||
|
|
@ -6,11 +6,7 @@
|
|||
"problem.rkt"
|
||||
"../show-scribbling.rkt"
|
||||
framework
|
||||
mzlib/class
|
||||
mzlib/unit
|
||||
mzlib/pretty
|
||||
mzlib/list
|
||||
mred)
|
||||
racket/gui)
|
||||
|
||||
(provide game@)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
(module problem mzscheme
|
||||
(provide (struct problem (name rows cols solution)))
|
||||
(define-struct problem (name rows cols solution)))
|
||||
(module problem racket
|
||||
(provide (struct-out problem))
|
||||
(define-struct problem (name rows cols solution) #:mutable))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -10,8 +10,6 @@ in ...
|
|||
|
||||
|#
|
||||
|
||||
(require mzlib/match)
|
||||
|
||||
;; shrink-file : string -> string
|
||||
(define (shrink-file filename)
|
||||
(printf "shrinking ~a..." filename)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang mzscheme
|
||||
(require mred
|
||||
mzlib/class)
|
||||
#lang racket
|
||||
(require racket/gui
|
||||
racket/class)
|
||||
(define argv (current-command-line-arguments))
|
||||
|
||||
(when (equal? (vector) argv)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -18,14 +18,9 @@ The col and row type specs are in sig.rkt and the solution type is:
|
|||
|
||||
(define argv (current-command-line-arguments))
|
||||
|
||||
(require mzlib/etc
|
||||
mzlib/list
|
||||
mzlib/file
|
||||
mzlib/pretty
|
||||
mzlib/class
|
||||
mred
|
||||
(require racket/gui
|
||||
"raw-hattori.rkt"
|
||||
(prefix solve: "../solve.rkt"))
|
||||
(prefix-in solve: "../solve.rkt"))
|
||||
|
||||
(if (equal? (vector) argv)
|
||||
(printf "pass any command line argument to skip the solver\n\n")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,4 @@
|
|||
(module solve mzscheme
|
||||
|
||||
(require mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/contract)
|
||||
|
||||
(module solve racket
|
||||
(provide/contract [solve (-> (listof (listof integer?)) ; row-info
|
||||
(listof (listof integer?)) ; col-info
|
||||
(-> number? number? symbol? ; set-entry
|
||||
|
|
@ -146,7 +141,7 @@
|
|||
((X) 'off)
|
||||
((O) 'on)
|
||||
((*) 'mixed)
|
||||
((()) ())
|
||||
((()) '())
|
||||
(else (error 'condensed->long-form "bad input: ~a" symbol-tree)))]))
|
||||
|
||||
;(equal? (condensed->long-form '(((? !) u) (* () X O)))
|
||||
|
|
@ -613,7 +608,7 @@
|
|||
[(new-board)
|
||||
(reassemble-rows (map rectify board-rows))]
|
||||
[( _ )
|
||||
(if row-changed
|
||||
(when row-changed
|
||||
(animate-changes new-board draw-rows-thunk
|
||||
(board-height new-board)
|
||||
(board-width new-board)))]
|
||||
|
|
@ -624,7 +619,7 @@
|
|||
[(final-board)
|
||||
(reassemble-cols (map rectify board-cols))]
|
||||
[( _ )
|
||||
(if col-changed
|
||||
(when col-changed
|
||||
(animate-changes final-board draw-cols-thunk
|
||||
(board-width final-board)
|
||||
(board-height final-board)))])
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ corresponds to the unplayed move! that's confusing.
|
|||
|
||||
|#
|
||||
|
||||
(module admin-gui mzscheme
|
||||
(module admin-gui racket
|
||||
(require "gui.rkt"
|
||||
"die.rkt"
|
||||
"interfaces.rkt"
|
||||
|
|
@ -15,16 +15,14 @@ corresponds to the unplayed move! that's confusing.
|
|||
"rules.rkt"
|
||||
"best-players.rkt"
|
||||
framework
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mred)
|
||||
racket/gui)
|
||||
|
||||
(provide gui-game%)
|
||||
|
||||
;; move-candidate = (make-move-candidate coordinate move (listof number))
|
||||
(define-struct move-candidate (move dice) (make-inspector))
|
||||
(define-struct move-candidate (move dice) #:inspector (make-inspector))
|
||||
|
||||
(define-struct past (board color roll) (make-inspector))
|
||||
(define-struct past (board color roll) #:inspector (make-inspector))
|
||||
(print-struct #t)
|
||||
|
||||
(define gui-game%
|
||||
|
|
@ -688,20 +686,20 @@ corresponds to the unplayed move! that's confusing.
|
|||
|
||||
;; eliminate-duplicates : (listof X) -> (listof X)
|
||||
(define (eliminate-duplicates lst)
|
||||
(let ([ht (make-hash-table 'equal)])
|
||||
(for-each (lambda (x) (hash-table-put! ht x #t)) lst)
|
||||
(hash-table-map ht (lambda (x y) x))))
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (lambda (x) (hash-set! ht x #t)) lst)
|
||||
(hash-map ht (lambda (x y) x))))
|
||||
|
||||
;; collapse-same-coordinates : (listof (cons coordinate (listof move-candidate)))
|
||||
;; -> (listof (cons coordinate (listof move-candidate)))
|
||||
(define (collapse-same-coordinates l)
|
||||
(let ([ht (make-hash-table 'equal)])
|
||||
(let ([ht (make-hash)])
|
||||
(for-each (lambda (pr)
|
||||
(hash-table-put! ht (car pr)
|
||||
(hash-set! ht (car pr)
|
||||
(append (cdr pr)
|
||||
(hash-table-get ht (car pr) (lambda () '())))))
|
||||
(hash-ref ht (car pr) (lambda () '())))))
|
||||
l)
|
||||
(hash-table-map ht cons)))
|
||||
(hash-map ht cons)))
|
||||
|
||||
;; like find-roll-coordinates, but only for the main track of the board
|
||||
(define (find-home-roll-coordinates board roll color)
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
(module admin mzscheme
|
||||
(module admin racket
|
||||
(require "board.rkt"
|
||||
"moves.rkt"
|
||||
"interfaces.rkt"
|
||||
mzlib/class
|
||||
mzlib/list)
|
||||
racket/class)
|
||||
|
||||
(provide game%
|
||||
game-observer<%>)
|
||||
|
|
|
|||
|
|
@ -10,15 +10,13 @@ careful charlie
|
|||
(random ron)
|
||||
|#
|
||||
|
||||
(module best-players mzscheme
|
||||
(module best-players racket
|
||||
(require "board.rkt"
|
||||
"moves.rkt"
|
||||
"interfaces.rkt"
|
||||
"test.rkt"
|
||||
mzlib/list
|
||||
mzlib/etc
|
||||
mzlib/class
|
||||
mzlib/pretty)
|
||||
racket/class
|
||||
racket/pretty)
|
||||
|
||||
(provide random-player%
|
||||
agressive-player%
|
||||
|
|
@ -28,7 +26,7 @@ careful charlie
|
|||
reckless-player%
|
||||
|
||||
search
|
||||
(struct state (moves dice board)))
|
||||
(struct-out state))
|
||||
|
||||
(define candidates-record '())
|
||||
(provide average-move-count)
|
||||
|
|
@ -41,7 +39,7 @@ careful charlie
|
|||
;; moves : (listof move) -- what got us here
|
||||
;; dice : (listof dice) -- what we have left to use
|
||||
;; board : board -- the state of the board after taking the moves
|
||||
(define-struct state (moves dice board) (make-inspector))
|
||||
(define-struct state (moves dice board) #:inspector (make-inspector))
|
||||
|
||||
(define base-player%
|
||||
(class* object% (player<%>)
|
||||
|
|
@ -140,24 +138,24 @@ careful charlie
|
|||
|
||||
;; search : board color (listof number) -> (listof state)
|
||||
(define (search orig-board color dice)
|
||||
(define candidate-ht (make-hash-table 'equal))
|
||||
(define candidate-ht (make-hash))
|
||||
(define (move-candidate candidate)
|
||||
(hash-table-put! candidate-ht (state-board candidate) candidate))
|
||||
(define (get-candidates) (hash-table-map candidate-ht (lambda (x y) y)))
|
||||
(hash-set! candidate-ht (state-board candidate) candidate))
|
||||
(define (get-candidates) (hash-map candidate-ht (lambda (x y) y)))
|
||||
|
||||
;; main : -> void
|
||||
(define (main)
|
||||
;; ht : board -o> true
|
||||
(let ([ht (make-hash-table 'equal)])
|
||||
(let ([ht (make-hash)])
|
||||
(let loop ([state (make-state '() dice orig-board)])
|
||||
(let* ([board (state-board state)]
|
||||
[dice (state-dice state)]
|
||||
[key (cons dice board)])
|
||||
(cond
|
||||
[(hash-table-get ht key (lambda () #f))
|
||||
[(hash-ref ht key (lambda () #f))
|
||||
(void)]
|
||||
[else
|
||||
(hash-table-put! ht key #t)
|
||||
(hash-set! ht key #t)
|
||||
(let* ([possible-moves (find-moves board dice)]
|
||||
[valid-next-states (find-valid-states state orig-board board possible-moves)])
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -1,19 +1,16 @@
|
|||
|
||||
(module board mzscheme
|
||||
(require mzlib/contract
|
||||
mzlib/list
|
||||
mzlib/etc)
|
||||
(module board racket
|
||||
|
||||
;; color = (symbols 'blue 'green 'red 'yellow)
|
||||
;; color : color
|
||||
;; id : (union 0 1 2 3)
|
||||
(define-struct pawn (color id index) (make-inspector))
|
||||
(define-struct pawn (color id index) #:inspector (make-inspector))
|
||||
|
||||
;; v : (vectorof loc) length is always 16
|
||||
(define-struct board (v) (make-inspector))
|
||||
(define-struct board (v) #:inspector (make-inspector))
|
||||
|
||||
;; loc = (union 'start 'home number[main-loc] home-row-loc)
|
||||
(define-struct home-row-loc (num color) (make-inspector))
|
||||
(define-struct home-row-loc (num color) #:inspector (make-inspector))
|
||||
|
||||
(define color (symbols 'red 'green 'blue 'yellow))
|
||||
|
||||
|
|
@ -23,12 +20,12 @@
|
|||
(pawn-id (pawn? . -> . (integer-in 0 4)))
|
||||
(pawn-color (pawn? . -> . color)))
|
||||
|
||||
(provide (rename build-pawn make-pawn)
|
||||
(provide (rename-out [build-pawn make-pawn])
|
||||
pawn?
|
||||
new-board
|
||||
for-each-pawn/loc
|
||||
|
||||
(rename make-old-style-board make-board)
|
||||
(rename-out [make-old-style-board make-board])
|
||||
|
||||
board-start
|
||||
|
||||
|
|
@ -204,15 +201,15 @@
|
|||
|
||||
;; find-blockades : board -> (listof loc)
|
||||
(define (find-blockades board)
|
||||
(let ([ht (make-hash-table 'equal)]
|
||||
(let ([ht (make-hash)]
|
||||
[blockades '()])
|
||||
(for-each-pawn/loc
|
||||
board
|
||||
(lambda (pawn loc)
|
||||
(when (hash-table-get ht
|
||||
(when (hash-ref ht
|
||||
loc
|
||||
(lambda ()
|
||||
(hash-table-put! ht loc #t)
|
||||
(hash-set! ht loc #t)
|
||||
#f))
|
||||
(set! blockades (cons loc blockades)))))
|
||||
blockades))
|
||||
|
|
@ -262,11 +259,11 @@
|
|||
;; p1 : pawn
|
||||
;; p2 : pawn
|
||||
;; (pawn<=? p1 p2) is true
|
||||
(define-struct blockade (loc p1 p2) (make-inspector))
|
||||
(define-struct blockade (loc p1 p2) #:inspector (make-inspector))
|
||||
|
||||
;; find-blockades/color : board color -> (listof blockade)
|
||||
(define (find-blockades/color board color)
|
||||
(let ([ht (make-hash-table 'equal)]
|
||||
(let ([ht (make-hash)]
|
||||
[v (board-v board)]
|
||||
[offset (find-pawn-index color 0)])
|
||||
(let loop ([i 0]
|
||||
|
|
@ -278,8 +275,8 @@
|
|||
(cond
|
||||
[(eq? loc 'start) (loop (+ i 1) blockades)]
|
||||
[(eq? loc 'home) (loop (+ i 1) blockades)]
|
||||
[(hash-table-get ht loc (lambda ()
|
||||
(hash-table-put! ht loc i)
|
||||
[(hash-ref ht loc (lambda ()
|
||||
(hash-set! ht loc i)
|
||||
#f))
|
||||
=>
|
||||
(lambda (old-i)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(module die mzscheme
|
||||
(require mred
|
||||
mzlib/class)
|
||||
(module die racket
|
||||
(require racket/gui
|
||||
racket/class)
|
||||
|
||||
(provide die%)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,7 @@
|
|||
(module gui mzscheme
|
||||
(module gui racket
|
||||
(require "board.rkt"
|
||||
"moves.rkt"
|
||||
mred
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/etc)
|
||||
racket/gui
|
||||
racket/class)
|
||||
|
||||
(provide show-board
|
||||
board-canvas%
|
||||
|
|
@ -16,10 +13,10 @@
|
|||
get-piece-size
|
||||
pawn-drawn-color
|
||||
|
||||
(struct home-row-c (count color))
|
||||
(struct main-c (count))
|
||||
(struct start-c (color))
|
||||
(struct home-c (color)))
|
||||
(struct-out home-row-c )
|
||||
(struct-out main-c )
|
||||
(struct-out start-c)
|
||||
(struct-out home-c))
|
||||
|
||||
;; a coordinate is either
|
||||
;; - (make-home-row-c number color)
|
||||
|
|
@ -27,10 +24,10 @@
|
|||
;; - (make-start-c color)
|
||||
;; - (make-home-c color)
|
||||
;; inspectors are to allow comparison with equal?
|
||||
(define-struct home-row-c (count color) (make-inspector))
|
||||
(define-struct main-c (count) (make-inspector))
|
||||
(define-struct start-c (color) (make-inspector))
|
||||
(define-struct home-c (color) (make-inspector))
|
||||
(define-struct home-row-c (count color) #:inspector (make-inspector))
|
||||
(define-struct main-c (count) #:inspector (make-inspector))
|
||||
(define-struct start-c (color) #:inspector (make-inspector))
|
||||
(define-struct home-c (color) #:inspector (make-inspector))
|
||||
|
||||
(define (get-cell-size horizontal? w h)
|
||||
(if horizontal?
|
||||
|
|
@ -63,7 +60,7 @@
|
|||
(send dc set-brush (send the-brush-list find-or-create-brush (cdr (assq color colors)) 'solid)))
|
||||
|
||||
(define draw-board
|
||||
(opt-lambda (board dc w h dx dy draw-pieces?)
|
||||
(lambda (board dc w h dx dy draw-pieces?)
|
||||
(let ([smoothing (send dc get-smoothing)])
|
||||
(send dc set-smoothing 'aligned)
|
||||
(set-color dc 'track-background)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
(module interfaces mzscheme
|
||||
(require mzlib/class)
|
||||
(module interfaces racket
|
||||
(provide player<%>
|
||||
game<%>)
|
||||
|
||||
|
|
@ -18,5 +17,4 @@
|
|||
(define game<%>
|
||||
(interface ()
|
||||
register ;; player<%> -> void
|
||||
start ;; -> void
|
||||
)))
|
||||
start #| -> void |#)))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,7 @@
|
|||
(module make-bitmap mzscheme
|
||||
(module make-bitmap racket
|
||||
(require "board.rkt"
|
||||
"moves.rkt"
|
||||
mred
|
||||
mzlib/class
|
||||
mzlib/list
|
||||
mzlib/etc)
|
||||
racket/gui
|
||||
racket/class)
|
||||
|
||||
(provide show-board
|
||||
board-canvas%
|
||||
|
|
@ -15,10 +12,10 @@
|
|||
get-cell-size
|
||||
get-piece-size
|
||||
|
||||
(struct home-row-c (count color))
|
||||
(struct main-c (count))
|
||||
(struct start-c (color))
|
||||
(struct home-c (color)))
|
||||
(struct-out home-row-c)
|
||||
(struct-out main-c)
|
||||
(struct-out start-c)
|
||||
(struct-out home-c))
|
||||
|
||||
;; a coordinate is either
|
||||
;; - (make-home-row-c number color)
|
||||
|
|
@ -26,10 +23,10 @@
|
|||
;; - (make-start-c color)
|
||||
;; - (make-home-c color)
|
||||
;; inspectors are to allow comparison with equal?
|
||||
(define-struct home-row-c (count color) (make-inspector))
|
||||
(define-struct main-c (count) (make-inspector))
|
||||
(define-struct start-c (color) (make-inspector))
|
||||
(define-struct home-c (color) (make-inspector))
|
||||
(define-struct home-row-c (count color) #:inspector (make-inspector))
|
||||
(define-struct main-c (count) #:inspector (make-inspector))
|
||||
(define-struct start-c (color) #:inspector (make-inspector))
|
||||
(define-struct home-c (color) #:inspector (make-inspector))
|
||||
|
||||
(define (get-cell-size horizontal? w h)
|
||||
(if horizontal?
|
||||
|
|
@ -52,7 +49,7 @@
|
|||
(send dc set-brush (send the-brush-list find-or-create-brush (cdr (assq color colors)) 'solid)))
|
||||
|
||||
(define draw-board
|
||||
(opt-lambda (board dc w h dx dy draw-pieces?)
|
||||
(lambda (board dc w h dx dy draw-pieces?)
|
||||
(set-color dc 'track-background)
|
||||
(send dc draw-rectangle (+ dx 0) (+ dy (* h 1/3)) w (* h 1/3))
|
||||
(send dc draw-rectangle (+ dx (* w 1/3)) (+ dy 0) (* w 1/3) h)
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
(module moves mzscheme
|
||||
(require "board.rkt"
|
||||
mzlib/contract
|
||||
mzlib/list)
|
||||
(module moves racket
|
||||
(require "board.rkt")
|
||||
|
||||
;; a move is either:
|
||||
;; - (make-enter-piece pawn)
|
||||
;; - (make-move-piece-main pawn start distance)
|
||||
;; - (make-move-piece-home pawn start distance)
|
||||
(define-struct move () (make-inspector))
|
||||
(define-struct (enter-piece move) (pawn) (make-inspector))
|
||||
(define-struct (move-piece-main move) (pawn start distance) (make-inspector))
|
||||
(define-struct (move-piece-home move) (pawn start distance) (make-inspector))
|
||||
(define-struct move () #:inspector (make-inspector))
|
||||
(define-struct (enter-piece move) (pawn) #:inspector (make-inspector))
|
||||
(define-struct (move-piece-main move) (pawn start distance) #:inspector (make-inspector))
|
||||
(define-struct (move-piece-home move) (pawn start distance) #:inspector (make-inspector))
|
||||
|
||||
(provide/contract
|
||||
(struct enter-piece ((pawn pawn?)))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
(module parcheesi mzscheme
|
||||
(require mzlib/unit
|
||||
mzlib/class
|
||||
(module parcheesi racket
|
||||
(require racket/unit
|
||||
racket/class
|
||||
"admin-gui.rkt")
|
||||
|
||||
(provide game@)
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
(module play-game mzscheme
|
||||
(module play-game racket
|
||||
(require "gui.rkt"
|
||||
"admin.rkt"
|
||||
"board.rkt"
|
||||
"moves.rkt"
|
||||
#;"moves.rkt"
|
||||
"die.rkt"
|
||||
mzlib/math
|
||||
mzlib/class
|
||||
mred)
|
||||
racket/gui)
|
||||
|
||||
(provide play-game)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,12 @@
|
|||
(module rules mzscheme
|
||||
(module rules racket
|
||||
(provide show-rules)
|
||||
|
||||
(require "board.rkt"
|
||||
"moves.rkt"
|
||||
"gui.rkt"
|
||||
|
||||
mzlib/class
|
||||
xml
|
||||
browser/htmltext
|
||||
mred)
|
||||
racket/gui)
|
||||
|
||||
(define board-size 250)
|
||||
|
||||
|
|
@ -223,7 +221,7 @@
|
|||
"Parcheesi typically requires a player to enter the board, if possible. That is not required "
|
||||
"here however." )))))
|
||||
|
||||
(define table (make-hash-table 'equal))
|
||||
(define table (make-hash))
|
||||
|
||||
(define (replace-!!s t)
|
||||
(let loop ([starts (reverse (send t find-string-all "!!"))]
|
||||
|
|
@ -234,7 +232,7 @@
|
|||
[end (car ends)]
|
||||
[name (send t get-text (+ start 2) end)])
|
||||
(send t delete start (+ end 2) #f)
|
||||
(send t insert (new board-snip% (board (hash-table-get table name))) start start #f)
|
||||
(send t insert (new board-snip% (board (hash-ref table name))) start start #f)
|
||||
(loop (cdr starts) (cdr ends)))])))
|
||||
|
||||
(define scroll-step-pixels 12)
|
||||
|
|
@ -267,5 +265,5 @@
|
|||
|
||||
(define (moves-make-image/link moves name)
|
||||
(let-values ([(board bonuses) (make-moves (new-board) moves)])
|
||||
(hash-table-put! table name board)
|
||||
(hash-set! table name board)
|
||||
(format " !!~a:: " name))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
(module test mzscheme
|
||||
(require mzlib/pretty)
|
||||
(module test racket
|
||||
(require racket/pretty)
|
||||
(provide test test-list test-err test-results)
|
||||
|
||||
(define show-tests? #t)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
(module board-size mzscheme
|
||||
(module board-size racket
|
||||
(define current-board-size (make-parameter 4))
|
||||
(provide current-board-size))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module board mzscheme
|
||||
(module board racket
|
||||
(require "board-size.rkt") ; for n
|
||||
|
||||
(provide x o none ; cell values
|
||||
|
|
@ -29,7 +29,7 @@
|
|||
(define o #\o)
|
||||
(define none #\space)
|
||||
|
||||
(define-struct board (str n rotation))
|
||||
(define-struct board (str n rotation) #:mutable)
|
||||
|
||||
(define (new-board n)
|
||||
(make-board (make-string (add1 (* n n)) #\space) n 0))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
;; This code benefits greatly from mzc compilation.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module counter mzscheme
|
||||
(module counter racket
|
||||
(require "board.rkt"
|
||||
"utils.rkt"
|
||||
mzlib/unitsig)
|
||||
|
|
|
|||
|
|
@ -3,9 +3,7 @@
|
|||
"board.rkt"
|
||||
"board-size.rkt"
|
||||
"../show-scribbling.rkt"
|
||||
racket/class
|
||||
racket/unit
|
||||
mred
|
||||
racket/gui
|
||||
(prefix-in robot: "robot.rkt"))
|
||||
|
||||
(provide game@)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module robot mzscheme
|
||||
(module robot racket
|
||||
(require "counter.rkt"
|
||||
"board.rkt"
|
||||
"utils.rkt"
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ move.
|
|||
The following example player program always mimics the other player,
|
||||
choosing T1 if it has to go first:
|
||||
|
||||
;; In the file my-robot.scm
|
||||
;; In the file my-robot.rkt
|
||||
(module my-robot mzscheme
|
||||
(provide robot)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(module utils mzscheme
|
||||
(module utils racket
|
||||
; See boardsig.rkt for the core utilities.
|
||||
(require "board-size.rkt"
|
||||
"board.rkt")
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/unit
|
||||
racket/list
|
||||
racket/gui/base
|
||||
racket/math
|
||||
"../show-scribbling.rkt"
|
||||
"same-lib.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
(module show-help mzscheme
|
||||
(require mzlib/class
|
||||
mred
|
||||
mzlib/etc)
|
||||
(module show-help racket
|
||||
(require racket/gui)
|
||||
|
||||
(provide show-help)
|
||||
|
||||
(define show-help
|
||||
(opt-lambda (collections frame-title [verbatim? #f])
|
||||
(lambda (collections frame-title [verbatim? #f])
|
||||
(let* ([f #f]
|
||||
[f%
|
||||
(class frame%
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require setup/xref
|
||||
scribble/xref
|
||||
scribble/basic
|
||||
scribble/tag
|
||||
scheme/promise
|
||||
net/url
|
||||
net/sendurl)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
#lang mzscheme
|
||||
(require mzlib/etc
|
||||
mzlib/class
|
||||
mzlib/unit
|
||||
mred)
|
||||
#lang racket
|
||||
(require racket/gui)
|
||||
|
||||
(provide game@)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,12 @@
|
|||
#lang mzscheme
|
||||
#lang racket
|
||||
|
||||
(require games/cards mred mzlib/class mzlib/list mzlib/file mzlib/unit
|
||||
(require games/cards racket/gui racket/class racket/unit
|
||||
"../show-scribbling.rkt")
|
||||
|
||||
(define (list-first-n l n)
|
||||
(if (zero? n)
|
||||
null
|
||||
(cons (car l) (list-first-n (cdr l) (sub1 n)))))
|
||||
(define (vector-copy v)
|
||||
(list->vector (vector->list v)))
|
||||
|
||||
(provide game@)
|
||||
(define game@ (unit (import) (export)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user