Split the games collection out of the main repository.
The `games` collection is now at https://github.com/racket/games
This commit is contained in:
Sam Tobin-Hochstadt
parent
8fa26e6f4f
commit
9b93478098
|
|
@ -1,11 +0,0 @@
|
|||
games
|
||||
Copyright (c) 2010-2014 PLT Design Inc.
|
||||
|
||||
This package is distributed under the GNU Lesser General Public
|
||||
License (LGPL). This means that you can link this package into proprietary
|
||||
applications, provided you follow the rules stated in the LGPL. You
|
||||
can also modify this package; if you distribute a modified version,
|
||||
you must distribute it under the terms of the LGPL, which in
|
||||
particular means that you must release the source code for the
|
||||
modified software. See http://www.gnu.org/copyleft/lesser.html
|
||||
for more information.
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 961 B |
|
|
@ -1,317 +0,0 @@
|
|||
#|
|
||||
|
||||
possible to disable dragging but still allow double-clicking?
|
||||
possible to remap single click (instead of double click)?
|
||||
|
||||
|#
|
||||
|
||||
#lang racket/base
|
||||
|
||||
(require games/cards racket/gui racket/unit string-constants
|
||||
"../show-scribbling.rkt")
|
||||
|
||||
(provide game@)
|
||||
(define game@ (unit (import) (export)
|
||||
|
||||
(define table (make-table "Aces" 6 5))
|
||||
|
||||
(make-object button% (string-constant help-menu-label) table
|
||||
(let ([show-help (show-scribbling '(lib "games/scribblings/games.scrbl")
|
||||
"aces")])
|
||||
(lambda x (show-help))))
|
||||
|
||||
(define draw-pile null)
|
||||
|
||||
(define card-height (send (car (make-deck)) card-height))
|
||||
(define card-width (send (car (make-deck)) card-width))
|
||||
(define region-height (send table table-height))
|
||||
|
||||
;; space between cards in the 4 stacks
|
||||
(define card-space 30)
|
||||
|
||||
(define-struct stack (x y cards) #:mutable)
|
||||
|
||||
(define (get-x-offset n)
|
||||
(let* ([table-width (send table table-width)]
|
||||
[stack-spacing 7]
|
||||
[num-stacks 5]
|
||||
[all-stacks-width (+ (* num-stacks card-width)
|
||||
(* (- num-stacks 1) stack-spacing))])
|
||||
(+ (- (/ table-width 2) (/ all-stacks-width 2))
|
||||
(* n (+ card-width stack-spacing)))))
|
||||
|
||||
(define draw-pile-region
|
||||
(make-button-region
|
||||
(get-x-offset 0)
|
||||
0
|
||||
card-width
|
||||
region-height ; card-height
|
||||
#f
|
||||
#f))
|
||||
|
||||
(define stacks
|
||||
(list (make-stack (get-x-offset 1) 0 null)
|
||||
(make-stack (get-x-offset 2) 0 null)
|
||||
(make-stack (get-x-offset 3) 0 null)
|
||||
(make-stack (get-x-offset 4) 0 null)))
|
||||
|
||||
;; type state = (make-state (listof cards) (listof[4] (listof cards)))
|
||||
(define-struct state (draw-pile stacks))
|
||||
|
||||
;; extract-current-state : -> state
|
||||
(define (extract-current-state)
|
||||
(make-state (copy-list draw-pile)
|
||||
(map (lambda (x) (copy-list (stack-cards x))) stacks)))
|
||||
|
||||
(define (copy-list l) (map (lambda (x) x) l))
|
||||
|
||||
;; install-state : -> void
|
||||
(define (install-state state)
|
||||
(send table begin-card-sequence)
|
||||
|
||||
;; erase all old snips
|
||||
(send table remove-cards draw-pile)
|
||||
(for ([stack (in-list stacks)])
|
||||
(send table remove-cards (stack-cards stack)))
|
||||
|
||||
;; restore old state
|
||||
(set! draw-pile (state-draw-pile state))
|
||||
(for ([stack (in-list stacks)]
|
||||
[cards (in-list (state-stacks state))])
|
||||
(set-stack-cards! stack cards))
|
||||
|
||||
;; restore GUI
|
||||
(for ([draw-pile-card (in-list draw-pile)])
|
||||
(send table add-card draw-pile-card 0 0))
|
||||
(send table move-cards-to-region draw-pile draw-pile-region)
|
||||
(for ([draw-pile-card (in-list (reverse draw-pile))])
|
||||
(send table card-face-down draw-pile-card)
|
||||
(send table card-to-front draw-pile-card))
|
||||
|
||||
(for ([stack (in-list stacks)])
|
||||
(define num-cards (length (stack-cards stack)))
|
||||
(send table add-cards (stack-cards stack) 0 0)
|
||||
(send table move-cards (stack-cards stack)
|
||||
(stack-x stack)
|
||||
(stack-y stack)
|
||||
(lambda (i)
|
||||
(values 0 (* (- num-cards i 1) card-space))))
|
||||
(send table cards-face-up (stack-cards stack)))
|
||||
(send table end-card-sequence))
|
||||
|
||||
;; undo-stack : (listof state)
|
||||
(define undo-stack null)
|
||||
|
||||
;; redo-stack : (listof state)
|
||||
(define redo-stack null)
|
||||
|
||||
;; save-undo : -> void
|
||||
;; saves the current state in the undo stack
|
||||
(define (save-undo)
|
||||
(set! undo-stack (cons (extract-current-state) undo-stack))
|
||||
(set! redo-stack null))
|
||||
|
||||
;; do-undo : -> void
|
||||
;; pre: (not (null? undo-stack))
|
||||
(define (do-undo)
|
||||
(let ([to-install (car undo-stack)])
|
||||
(set! redo-stack (cons (extract-current-state) redo-stack))
|
||||
(set! undo-stack (cdr undo-stack))
|
||||
(install-state to-install)))
|
||||
|
||||
;; do-redo : -> void
|
||||
;; pre: (not (null? redo-stack))
|
||||
(define (do-redo)
|
||||
(let ([to-install (car redo-stack)])
|
||||
(set! undo-stack (cons (extract-current-state) undo-stack))
|
||||
(set! redo-stack (cdr redo-stack))
|
||||
(install-state to-install)))
|
||||
|
||||
(define (position-cards stack)
|
||||
(let ([m (length (stack-cards stack))])
|
||||
(lambda (i)
|
||||
(values 0 (if (= m 0) 0 (* (- m i 1) card-space))))))
|
||||
|
||||
(define (reset-game)
|
||||
(send table remove-cards draw-pile)
|
||||
(for ([stack (in-list stacks)])
|
||||
(send table remove-cards (stack-cards stack)))
|
||||
|
||||
(set! undo-stack null)
|
||||
(set! redo-stack null)
|
||||
|
||||
(let* ([deck (shuffle-list (make-deck) 7)]
|
||||
[set-stack
|
||||
(lambda (which)
|
||||
(set-stack-cards! (which stacks) (list (which deck))))])
|
||||
(for ([card (in-list deck)])
|
||||
(send card user-can-move #f)
|
||||
(send card user-can-flip #f))
|
||||
(set! draw-pile (cddddr deck))
|
||||
(set-stack car)
|
||||
(set-stack cadr)
|
||||
(set-stack caddr)
|
||||
(set-stack cadddr))
|
||||
|
||||
(for ([stack (in-list stacks)])
|
||||
(send table add-cards
|
||||
(stack-cards stack)
|
||||
(stack-x stack)
|
||||
(stack-y stack)
|
||||
(position-cards stack))
|
||||
(for ([card (in-list (stack-cards stack))]) (send card flip)))
|
||||
|
||||
(send table add-cards-to-region draw-pile draw-pile-region))
|
||||
|
||||
(define (move-from-deck)
|
||||
(save-undo)
|
||||
(unless (null? draw-pile)
|
||||
(define (move-one select)
|
||||
(let ([stack (select stacks)]
|
||||
[card (select draw-pile)])
|
||||
(set-stack-cards! stack (cons card (stack-cards stack)))
|
||||
(send table card-to-front card)
|
||||
(send table flip-card card)))
|
||||
|
||||
(send table begin-card-sequence)
|
||||
(move-one car)
|
||||
(move-one cadr)
|
||||
(move-one caddr)
|
||||
(move-one cadddr)
|
||||
(send table end-card-sequence)
|
||||
|
||||
(let ([cards-to-move (list (car draw-pile)
|
||||
(cadr draw-pile)
|
||||
(caddr draw-pile)
|
||||
(cadddr draw-pile))])
|
||||
(send table move-cards cards-to-move
|
||||
0 0
|
||||
(lambda (i)
|
||||
(define stack (list-ref stacks i))
|
||||
(define-values [dx dy] ((position-cards stack) 0))
|
||||
(values (+ dx (stack-x stack))
|
||||
(+ dy (stack-y stack))))))
|
||||
|
||||
(set! draw-pile (cddddr draw-pile))
|
||||
|
||||
(send table move-cards-to-region draw-pile draw-pile-region)))
|
||||
|
||||
(define (move-to-empty-spot card stack)
|
||||
(save-undo)
|
||||
(send table move-cards
|
||||
(list card)
|
||||
(stack-x stack)
|
||||
(stack-y stack)
|
||||
(position-cards stack))
|
||||
(remove-card-from-stacks card)
|
||||
(set-stack-cards! stack (cons card (stack-cards stack))))
|
||||
|
||||
(define (remove-card card)
|
||||
(save-undo)
|
||||
(send table remove-card card)
|
||||
(remove-card-from-stacks card))
|
||||
|
||||
(define (remove-card-from-stacks card)
|
||||
(define old-cards (map stack-cards stacks))
|
||||
(for ([stack (in-list stacks)])
|
||||
(set-stack-cards! stack (remq card (stack-cards stack))))
|
||||
(for ([stack (in-list stacks)]
|
||||
[old-cards (in-list old-cards)])
|
||||
(unless (equal? (stack-cards stack) old-cards)
|
||||
(send table move-cards
|
||||
(stack-cards stack)
|
||||
(stack-x stack)
|
||||
(stack-y stack)
|
||||
(position-cards stack)))))
|
||||
|
||||
(send table set-single-click-action
|
||||
(lambda (card)
|
||||
(if (send card face-down?)
|
||||
(move-from-deck)
|
||||
(let ([bottom-four
|
||||
(let loop ([l stacks])
|
||||
(if (null? l)
|
||||
null
|
||||
(let ([stack (car l)])
|
||||
(if (null? (stack-cards stack))
|
||||
(loop (cdr l))
|
||||
(cons (car (stack-cards stack)) (loop (cdr l)))))))])
|
||||
(when (memq card bottom-four)
|
||||
(if (ormap (lambda (bottom-card)
|
||||
(and (eq? (send card get-suit)
|
||||
(send bottom-card get-suit))
|
||||
(or (and (not (= 1 (send card get-value)))
|
||||
(= 1 (send bottom-card get-value)))
|
||||
(and (not (= 1 (send card get-value)))
|
||||
(< (send card get-value)
|
||||
(send bottom-card get-value))))))
|
||||
bottom-four)
|
||||
(remove-card card)
|
||||
(let loop ([stacks stacks])
|
||||
(if (null? stacks)
|
||||
(void)
|
||||
(let ([stack (car stacks)])
|
||||
(if (null? (stack-cards stack))
|
||||
(move-to-empty-spot card stack)
|
||||
(loop (cdr stacks))))))))))
|
||||
(check-game-over)))
|
||||
|
||||
(define (game-over?)
|
||||
(and (null? draw-pile)
|
||||
(let ([suits/false
|
||||
(map (lambda (x)
|
||||
(let ([stack-cards (stack-cards x)])
|
||||
(if (null? stack-cards)
|
||||
#f
|
||||
(send (car stack-cards) get-suit))))
|
||||
stacks)])
|
||||
(and (not (member #f suits/false))
|
||||
(memq 'clubs suits/false)
|
||||
(memq 'diamonds suits/false)
|
||||
(memq 'hearts suits/false)
|
||||
(memq 'spades suits/false)))))
|
||||
|
||||
(define (won?)
|
||||
(and (game-over?)
|
||||
(andmap (lambda (x)
|
||||
(define cards (stack-cards x))
|
||||
(and (not (null? cards))
|
||||
(null? (cdr cards))
|
||||
(= 1 (send (car cards) get-value))))
|
||||
stacks)))
|
||||
|
||||
(define (check-game-over)
|
||||
(when (game-over?)
|
||||
(case (message-box "Aces"
|
||||
(if (won?)
|
||||
"Congratulations! You win! Play again?"
|
||||
"Game Over. Play again?")
|
||||
table
|
||||
'(yes-no))
|
||||
[(yes) (reset-game)]
|
||||
[(no) (send table show #f)])))
|
||||
|
||||
(send table add-region draw-pile-region)
|
||||
(reset-game)
|
||||
|
||||
(define mb (or (send table get-menu-bar)
|
||||
(make-object menu-bar% table)))
|
||||
(define edit-menu (new menu% [parent mb] [label (string-constant edit-menu)]))
|
||||
(new menu-item%
|
||||
[label (string-constant undo-menu-item)]
|
||||
[parent edit-menu]
|
||||
[callback (lambda (x y) (do-undo))]
|
||||
[shortcut #\z]
|
||||
[demand-callback
|
||||
(lambda (item) (send item enable (not (null? undo-stack))))])
|
||||
(new menu-item%
|
||||
[label (string-constant redo-menu-item)]
|
||||
[parent edit-menu]
|
||||
[callback (lambda (x y) (do-redo))]
|
||||
[shortcut #\y]
|
||||
[demand-callback
|
||||
(lambda (item) (send item enable (not (null? redo-stack))))])
|
||||
|
||||
(send table show #t)
|
||||
|
||||
))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define game "aces.rkt")
|
||||
(define game-set "Card Games")
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 977 B |
|
|
@ -1,437 +0,0 @@
|
|||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Blackjack
|
||||
;;
|
||||
;; The standard rules apply. Specifics:
|
||||
;;
|
||||
;; 1 player (not counting the dealer)
|
||||
;;
|
||||
;; 4 decks, reshuffled after 3/4 of the cards are used
|
||||
;;
|
||||
;; Dealer stands on soft 17s
|
||||
;;
|
||||
;; Splitting allowed only on the first two cards, and only if they
|
||||
;; are equal; 10 and the face cards are all considered equal for
|
||||
;; splitting
|
||||
;;
|
||||
;; Doubling allowed on all unsplit hands, not on split hands
|
||||
;;
|
||||
;; No blackjacks after splitting
|
||||
;;
|
||||
;; No surrender
|
||||
;;
|
||||
;; No insurance
|
||||
;;
|
||||
;; No maximum under-21 hand size
|
||||
;;
|
||||
;; Dealer's second card is not revealed if the player busts (or
|
||||
;; both halves of a split hand bust)
|
||||
;;
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
#lang racket
|
||||
|
||||
(require games/cards racket/gui racket/class racket/unit)
|
||||
|
||||
(provide game@)
|
||||
(define game@ (unit (import) (export)
|
||||
|
||||
;; Number of decks to use
|
||||
(define DECK-COUNT 4)
|
||||
|
||||
;; Region layout constants
|
||||
(define MARGIN 10)
|
||||
(define SUBMARGIN 10)
|
||||
(define LABEL-H 15)
|
||||
|
||||
;; Randomize
|
||||
(random-seed (modulo (current-milliseconds) 10000))
|
||||
|
||||
;; Reshuffle when 3/4 of the deck is used
|
||||
(define min-deck-size (/ (* DECK-COUNT 52) 4))
|
||||
|
||||
;; Set up the table
|
||||
(define t (make-table "Blackjack" 6 3))
|
||||
(define status-pane (send t create-status-pane))
|
||||
(send t add-scribble-button status-pane
|
||||
'(lib "games/scribblings/games.scrbl") "blackjack")
|
||||
(send t show #t)
|
||||
(send t set-double-click-action #f)
|
||||
(send t set-button-action 'left 'drag/one)
|
||||
(send t set-button-action 'middle 'drag/one)
|
||||
(send t set-button-action 'right 'drag/one)
|
||||
|
||||
;; Get table width & height
|
||||
(define w (send t table-width))
|
||||
(define h (send t table-height))
|
||||
|
||||
;; Build the deck
|
||||
(define deck
|
||||
(let loop ([n DECK-COUNT])
|
||||
(if (zero? n)
|
||||
null
|
||||
(append (make-deck) (loop (sub1 n))))))
|
||||
|
||||
;; Card width & height
|
||||
(define cw (send (car deck) card-width))
|
||||
(define ch (send (car deck) card-height))
|
||||
|
||||
;; Size of buttons
|
||||
(define BUTTON-HEIGHT 16)
|
||||
(define BUTTON-WIDTH cw)
|
||||
|
||||
;; Cards are not movable
|
||||
(for-each (lambda (card) (send* card (user-can-move #f) (user-can-flip #f)))
|
||||
deck)
|
||||
|
||||
;; Set up card regions
|
||||
(define deck-region
|
||||
(make-region MARGIN MARGIN cw ch #f #f))
|
||||
|
||||
(define discard-region
|
||||
(make-region (- w cw MARGIN) MARGIN cw ch #f #f))
|
||||
|
||||
(define dealer-region
|
||||
(make-region (+ cw (* 2 MARGIN)) MARGIN
|
||||
(- w (* 2 cw) (* 4 MARGIN)) ch
|
||||
#f #f))
|
||||
|
||||
(define player-region
|
||||
(make-region (+ cw (* 2 MARGIN)) (- h (* 2 MARGIN) ch BUTTON-HEIGHT)
|
||||
(- w (* 2 cw) (* 4 MARGIN)) ch
|
||||
#f #f))
|
||||
|
||||
;; In case of split, we need more regions
|
||||
(define ww (* 3/2 cw))
|
||||
(define player-2-region
|
||||
(make-region MARGIN (region-y player-region)
|
||||
(- w ww (* 3 MARGIN)) (region-h player-region)
|
||||
#f #f))
|
||||
(define player-2-wait-region
|
||||
(make-region (region-x player-2-region) (region-y player-2-region)
|
||||
ww (region-h player-2-region)
|
||||
#f #f))
|
||||
(define player-1-region
|
||||
(make-region (- w MARGIN (region-w player-2-region)) (region-y player-2-region)
|
||||
(region-w player-2-region) (region-h player-2-region)
|
||||
#f #f))
|
||||
(define player-1-wait-region
|
||||
(make-region (- (+ (region-x player-1-region) (region-w player-1-region)) ww)
|
||||
(region-y player-1-region)
|
||||
ww (region-h player-1-region)
|
||||
#f #f))
|
||||
(define (make-border-region r)
|
||||
(define hm (/ MARGIN 2))
|
||||
(make-region (- (region-x r) hm) (- (region-y r) hm)
|
||||
(+ (region-w r) MARGIN) (+ (region-h r) MARGIN)
|
||||
"" #f))
|
||||
(define player-1-border (make-border-region player-1-region))
|
||||
(define player-2-border (make-border-region player-2-region))
|
||||
|
||||
;; Player buttons
|
||||
(define (make-button title pos)
|
||||
(make-button-region (+ (/ (- w (* 4 BUTTON-WIDTH) (* 3 MARGIN)) 2)
|
||||
(* pos (+ BUTTON-WIDTH MARGIN)))
|
||||
(- h MARGIN BUTTON-HEIGHT)
|
||||
BUTTON-WIDTH BUTTON-HEIGHT
|
||||
title void))
|
||||
(define hit-button (make-button "Hit" 1))
|
||||
(define stand-button (make-button "Stand" 2))
|
||||
(define split-button (make-button "Split" 0))
|
||||
(define double-button (make-button "Double" 3))
|
||||
|
||||
;; Put the cards on the table
|
||||
(send t add-cards-to-region deck deck-region)
|
||||
|
||||
;; Function to compute the normal or minimum value of a card
|
||||
(define (min-card-value c)
|
||||
(let ([v (send c get-value)]) (if (> v 10) 10 v)))
|
||||
|
||||
;; Function to compute the value of a hand, counting aces as 1 or 11
|
||||
;; to get the highest total possible under 21
|
||||
(define (best-total l)
|
||||
(let* ([ace? (lambda (is?) (lambda (c) (eq? is? (= (send c get-value) 1))))]
|
||||
[aces (filter (ace? #t) l)]
|
||||
[others (filter (ace? #f) l)]
|
||||
[base (apply + (map min-card-value others))])
|
||||
(let loop ([l aces][base base])
|
||||
(cond [(null? l) base]
|
||||
[(<= (+ base (* (length aces) 11)) 21)
|
||||
(+ base (* (length aces) 11))]
|
||||
[else (loop (cdr l) (add1 base))]))))
|
||||
|
||||
;; Function to test whether a hand is a bust
|
||||
(define (bust? p)
|
||||
(> (best-total p) 21))
|
||||
|
||||
;; Very simple betting...
|
||||
(define money 100)
|
||||
(define (update-money! d)
|
||||
(set! money (+ money d))
|
||||
(send t set-status (format "You have $~a. (Each bet is $2.)" money)))
|
||||
|
||||
;; Let's play!
|
||||
(let shuffle-loop ()
|
||||
;; Shuffle the cards, none are discarded, yet
|
||||
(let* ([deck (shuffle-list deck 7)]
|
||||
[discard null]
|
||||
[deal (lambda (n)
|
||||
(let deal ([n n])
|
||||
(if (zero? n)
|
||||
null
|
||||
(let ([c (car deck)])
|
||||
(set! deck (cdr deck))
|
||||
(cons c (deal (sub1 n)))))))])
|
||||
;; Put the shuffled deck in place
|
||||
(send t move-cards-to-region deck deck-region)
|
||||
(send t stack-cards deck)
|
||||
;; Loop rounds over while there's enough cards in the deck
|
||||
(let loop ()
|
||||
;; All bets are $2
|
||||
(update-money! -2)
|
||||
;; Deal to player
|
||||
(let ([p (deal 2)]
|
||||
[p2 null] ; in case of splitting
|
||||
[double? #f]) ; in case of doubling (flag is needed to adjust money)
|
||||
;; Move the player's cards into place and show them
|
||||
(send t move-cards-to-region p player-region)
|
||||
(send t cards-face-up p)
|
||||
;; Deal to dealer
|
||||
(let ([d (deal 2)])
|
||||
;; Move the dealer's cards into place and show one
|
||||
(send t move-cards-to-region d dealer-region)
|
||||
(send t card-face-up (car d))
|
||||
(let* ([continue (make-semaphore)]
|
||||
;; Make a button in the center to show results
|
||||
[make-status
|
||||
(lambda (title continue)
|
||||
(let ([r (make-button-region
|
||||
(/ (- w (* 2 cw)) 2)
|
||||
(region-y hit-button)
|
||||
(* 2 cw) BUTTON-HEIGHT
|
||||
title #f)])
|
||||
(set-region-callback! r (lambda ()
|
||||
(send t remove-region r)
|
||||
(semaphore-post continue)))
|
||||
r))]
|
||||
;; Done with hand:
|
||||
[done
|
||||
(lambda (title continue)
|
||||
(send t remove-region hit-button)
|
||||
(send t remove-region stand-button)
|
||||
(send t add-region (make-status title continue)))]
|
||||
;; Compute winnings (not called for busts by the player)
|
||||
[finish
|
||||
(lambda (p blackjack?)
|
||||
(let ([pt (best-total p)]
|
||||
[dt (best-total d)]
|
||||
[continue (make-semaphore)])
|
||||
(cond
|
||||
[(or (> dt 21) (> pt dt))
|
||||
(update-money! (if blackjack? 5 (if double? 8 4)))
|
||||
(done (if blackjack?
|
||||
"Blackjack"
|
||||
"You Win")
|
||||
continue)]
|
||||
[(> dt pt)
|
||||
(done (if blackjack?
|
||||
"Dealer Blackjack"
|
||||
"You Lose")
|
||||
continue)]
|
||||
[else (update-money! (if double? 4 2))
|
||||
(done "Push" continue)])
|
||||
(yield continue)))]
|
||||
;; Done with the first hand of a split
|
||||
[finish-split
|
||||
(lambda (p player-region player-wait-region player-border)
|
||||
(unless (bust? p)
|
||||
(send t move-cards-to-region p player-region)
|
||||
(send t add-region player-border)
|
||||
(finish p #f)
|
||||
(send t remove-region player-border)
|
||||
(send t move-cards-to-region p player-wait-region)))]
|
||||
;; Player busts
|
||||
[bust (lambda ()
|
||||
(done "Bust" continue))]
|
||||
;; Bust in one hand of a split
|
||||
[local-bust (lambda ()
|
||||
(let ([cont (make-semaphore)])
|
||||
(done "Bust" cont)
|
||||
(yield cont)))]
|
||||
;; Callback for the hit button; the button's callback is
|
||||
;; changed for different modes: normal, split part 1, or split
|
||||
;; part 2
|
||||
[make-hit-callback
|
||||
(lambda (get-p set-p! player-region bust)
|
||||
(lambda ()
|
||||
(send t remove-region double-button)
|
||||
(send t remove-region split-button)
|
||||
(set-p! (append (deal 1) (get-p)))
|
||||
(send t stack-cards (get-p))
|
||||
(send t move-cards-to-region (get-p) player-region)
|
||||
(send t cards-face-up (get-p))
|
||||
;; Check for bust
|
||||
(when (bust? (get-p)) (bust))))])
|
||||
;; Blackjack by player or dealer?
|
||||
(if (or (= 21 (best-total p))
|
||||
(= 21 (best-total d)))
|
||||
(begin
|
||||
;; Show the dealers cards...
|
||||
(send t cards-face-up d)
|
||||
;; ... and compute the result
|
||||
(finish p #t))
|
||||
(begin
|
||||
;; Three basic actions are allowed:
|
||||
(send t add-region hit-button)
|
||||
(send t add-region stand-button)
|
||||
(send t add-region double-button)
|
||||
;; Set the callbacks for normal (unsplit) hands
|
||||
(set-region-callback!
|
||||
hit-button
|
||||
(make-hit-callback (lambda () p)
|
||||
(lambda (v) (set! p v))
|
||||
player-region
|
||||
bust))
|
||||
(set-region-callback!
|
||||
stand-button
|
||||
(lambda () (semaphore-post continue)))
|
||||
(set-region-callback!
|
||||
double-button
|
||||
(lambda ()
|
||||
;; Note the double for adjusting money on a win
|
||||
(set! double? #t)
|
||||
;; Double the bet
|
||||
(update-money! -2)
|
||||
;; Deal one more card
|
||||
((region-callback hit-button))
|
||||
;; No more cards or actions, but if the player busted, the
|
||||
;; hit callback has already continued
|
||||
(unless (bust? p) (semaphore-post continue))))
|
||||
;; Split allowed?
|
||||
(when (= (min-card-value (car p)) (min-card-value (cadr p)))
|
||||
;; Yes, we can split. If the player hits the split button, we
|
||||
;; have to split the cards, deal one more to each split half
|
||||
;; and adjust the callbacks for hit and stand. (If aces are
|
||||
;; split, the round is over.)
|
||||
(send t add-region split-button)
|
||||
(set-region-callback!
|
||||
split-button
|
||||
(lambda ()
|
||||
;; Double our bet...
|
||||
(update-money! -2)
|
||||
;; Split the hand
|
||||
(set! p2 (list (cadr p)))
|
||||
(set! p (list (car p)))
|
||||
;; Move the split halves to the "waiting" area. The active
|
||||
;; area is reserved for hands that are being played
|
||||
(send t move-cards-to-region p player-1-wait-region)
|
||||
(send t move-cards-to-region p2 player-2-wait-region)
|
||||
;; Deal one more card to each half and move them into
|
||||
;; place
|
||||
(set! p (append (deal 1) p))
|
||||
(set! p2 (append (deal 1) p2))
|
||||
(send t stack-cards p)
|
||||
(send t stack-cards p2)
|
||||
(send t move-cards-to-region p player-1-wait-region)
|
||||
(send t move-cards-to-region p2 player-2-wait-region)
|
||||
;; Show the newly dealt cards
|
||||
(send t flip-cards (list (car p) (car p2)))
|
||||
;; No more splits, no doubling
|
||||
(send t remove-region split-button)
|
||||
(send t remove-region double-button)
|
||||
;; Function called when the last split hand is done
|
||||
(let* ([close-split
|
||||
(lambda ()
|
||||
;; Unhilite the second hand
|
||||
(send t remove-region player-2-border)
|
||||
(send t move-cards-to-region p2 player-2-wait-region)
|
||||
;; Let the main loop finish up
|
||||
(semaphore-post continue))]
|
||||
;; Callback to swicth from the first split hand to
|
||||
;; the second
|
||||
[switch
|
||||
(lambda ()
|
||||
;; Unhilite the first hand
|
||||
(send t remove-region player-1-border)
|
||||
(send t move-cards-to-region p player-1-wait-region)
|
||||
;; Hilite the second hand
|
||||
(send t move-cards-to-region p2 player-2-region)
|
||||
(send t add-region player-2-border)
|
||||
;; Adjust callbacks to operate on the second hand
|
||||
(set-region-callback!
|
||||
hit-button
|
||||
(make-hit-callback (lambda () p2)
|
||||
(lambda (v) (set! p2 v))
|
||||
player-2-region
|
||||
(lambda ()
|
||||
(local-bust)
|
||||
(close-split))))
|
||||
(set-region-callback!
|
||||
stand-button
|
||||
close-split))])
|
||||
;; Did we split aces?
|
||||
(if (= 1 (send (cadr p) get-value))
|
||||
;; Split aces; no more cards
|
||||
(semaphore-post continue)
|
||||
(begin
|
||||
;; The first of the split hands is ready to go
|
||||
(send t move-cards-to-region p player-1-region)
|
||||
;; Hilite the first hand
|
||||
(send t add-region player-1-border)
|
||||
;; Adjust callbacks to work on the first of a split
|
||||
;; hand
|
||||
(set-region-callback!
|
||||
hit-button
|
||||
(make-hit-callback (lambda () p)
|
||||
(lambda (v) (set! p v))
|
||||
player-1-region
|
||||
(lambda ()
|
||||
(local-bust)
|
||||
(switch)
|
||||
(send t add-region hit-button)
|
||||
(send t add-region stand-button))))
|
||||
(set-region-callback! stand-button switch)))))))
|
||||
;; Wait until the player is done
|
||||
(yield continue)
|
||||
;; No more player actions; get rid of the buttons
|
||||
(send t remove-region hit-button)
|
||||
(send t remove-region stand-button)
|
||||
(send t remove-region double-button)
|
||||
(send t remove-region split-button)
|
||||
;; If all the player's hards are bust, the dealer doesn't do
|
||||
;; anything
|
||||
(unless (and (bust? p) (or (null? p2) (bust? p2)))
|
||||
;; Show the dealer's starting hand
|
||||
(send t card-face-up (cadr d))
|
||||
(let loop ()
|
||||
;; Hit on 16 or lower, stand on 17 and higher
|
||||
(when (< (best-total d) 17)
|
||||
;; Hit the dealer
|
||||
(set! d (append (deal 1) d))
|
||||
(send t stack-cards d)
|
||||
(send t move-cards-to-region d dealer-region)
|
||||
(send t cards-face-up d)
|
||||
(loop)))
|
||||
(if (null? p2)
|
||||
;; Finish normal game (adjusts winnings)
|
||||
(finish p #f)
|
||||
;; Finish split game (adjusts winnings for each hand)
|
||||
(begin
|
||||
(finish-split p player-1-region player-1-wait-region player-1-border)
|
||||
(finish-split p2 player-2-region player-2-wait-region player-2-border))))))
|
||||
;; Move all the discarded cards to the back
|
||||
(unless (null? discard)
|
||||
(send t card-to-back (car discard))
|
||||
(send t stack-cards discard))
|
||||
;; Discard all the cards we used
|
||||
(set! discard (append p p2 d discard))
|
||||
(send t cards-face-down discard)
|
||||
(send t move-cards-to-region discard discard-region)
|
||||
;; Go again. Check whether we should reshuffle the deck or keep
|
||||
;; going with this one
|
||||
(if (< (length deck) min-deck-size)
|
||||
(begin (send t move-cards-to-region deck discard-region)
|
||||
(shuffle-loop))
|
||||
(loop))))))))
|
||||
|
||||
))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define game "blackjack.rkt")
|
||||
(define game-set "Card Games")
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(require "cards/cards.rkt")
|
||||
(provide (all-from-out "cards/cards.rkt"))
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
(module base racket
|
||||
(require racket/class
|
||||
"make-cards.rkt" "classes.rkt" "card-class.rkt")
|
||||
|
||||
(provide make-table make-deck make-card
|
||||
table<%> card<%>)
|
||||
|
||||
(define table<%> (class->interface table%))
|
||||
(define card<%> (class->interface card%))
|
||||
|
||||
(define make-table
|
||||
(lambda ([title "Cards"][w 7][h 3])
|
||||
(make-object table% title w h)))
|
||||
|
||||
(define (make-deck)
|
||||
(map (lambda (l) (send l copy)) deck-of-cards)))
|
||||
|
|
@ -1,256 +0,0 @@
|
|||
|
||||
(module card-class racket/base
|
||||
(require racket/class
|
||||
racket/shared
|
||||
(prefix-in mred: racket/gui)
|
||||
"snipclass.rkt"
|
||||
"region.rkt")
|
||||
|
||||
(provide card%)
|
||||
|
||||
(define prev-regions #f)
|
||||
(define prev-region-dc #f)
|
||||
|
||||
(define (rotate-bm bm cw?)
|
||||
(let ([w (send bm get-width)]
|
||||
[h (send bm get-height)])
|
||||
(let ([bm2 (mred:make-bitmap h w)]
|
||||
[s (make-bytes (* w h 4))]
|
||||
[s2 (make-bytes (* h w 4))])
|
||||
(send bm get-argb-pixels 0 0 w h s)
|
||||
(for ([i (in-range w)])
|
||||
(for ([j (in-range h)])
|
||||
(let ([src-pos (* (+ i (* j w)) 4)])
|
||||
(bytes-copy! s2
|
||||
(if cw?
|
||||
(* (+ (- (- h j) 1) (* i h)) 4)
|
||||
(* (+ j (* (- (- w i) 1) h)) 4))
|
||||
s src-pos (+ src-pos 4)))))
|
||||
(let ([dc (make-object mred:bitmap-dc% bm2)])
|
||||
(send dc set-argb-pixels 0 0 h w s2)
|
||||
(send dc set-bitmap #f))
|
||||
bm2)))
|
||||
|
||||
(define orientations (shared ([o (list* 'n 'e 's 'w o)]) o))
|
||||
(define (find-head l s)
|
||||
(if (eq? (car l) s)
|
||||
l
|
||||
(find-head (cdr l) s)))
|
||||
|
||||
(define card%
|
||||
(class mred:snip%
|
||||
(init -suit-id -value -width -height -front -back -mk-dim-front -mk-dim-back -rotated-bms)
|
||||
(inherit set-snipclass set-count get-admin)
|
||||
(define suit-id -suit-id)
|
||||
(define value -value)
|
||||
(define width -width)
|
||||
(define height -height)
|
||||
(define rotated 'n)
|
||||
(define front -front)
|
||||
(define back -back)
|
||||
(define mk-dim-front -mk-dim-front)
|
||||
(define mk-dim-back -mk-dim-back)
|
||||
(define dim-front #f)
|
||||
(define dim-back #f)
|
||||
(define is-dim? #f)
|
||||
(define flipped? #f)
|
||||
(define semi-flipped? #f)
|
||||
(define can-flip? #t)
|
||||
(define can-move? #t)
|
||||
(define snap-back? #f)
|
||||
(define stay-region #f)
|
||||
(define home-reg #f)
|
||||
(define rotated-bms -rotated-bms)
|
||||
(private*
|
||||
[refresh
|
||||
(lambda ()
|
||||
(let ([a (get-admin)])
|
||||
(when a
|
||||
(send a needs-update this 0 0 width height))))]
|
||||
[refresh-size
|
||||
(lambda ()
|
||||
(let ([a (get-admin)])
|
||||
(when a
|
||||
(send a resized this #f)))
|
||||
(refresh))]
|
||||
[check-dim
|
||||
(lambda ()
|
||||
(when is-dim?
|
||||
(if flipped?
|
||||
(unless dim-back
|
||||
(set! dim-back (mk-dim-back)))
|
||||
(unless dim-front
|
||||
(set! dim-front (mk-dim-front))))))]
|
||||
[get-rotated
|
||||
(lambda (bm dir)
|
||||
(if (eq? dir 'n)
|
||||
bm
|
||||
(or (hash-ref rotated-bms (cons dir bm) #f)
|
||||
(let ([rotated-bm (case dir
|
||||
[(w) (rotate-bm bm #f)]
|
||||
[(e) (rotate-bm bm #t)]
|
||||
[(s) (rotate-bm (rotate-bm bm #t) #t)])])
|
||||
(hash-set! rotated-bms (cons dir bm) rotated-bm)
|
||||
rotated-bm))))])
|
||||
(public*
|
||||
[face-down? (lambda () flipped?)]
|
||||
[flip
|
||||
(lambda ()
|
||||
(set! flipped? (not flipped?))
|
||||
(refresh))]
|
||||
[semi-flip
|
||||
(lambda ()
|
||||
(set! semi-flipped? (not semi-flipped?))
|
||||
(refresh))]
|
||||
[face-up (lambda () (when flipped? (flip)))]
|
||||
[face-down (lambda () (unless flipped? (flip)))]
|
||||
[dim (case-lambda
|
||||
[() is-dim?]
|
||||
[(v)
|
||||
(unless (eq? is-dim? (and v #t))
|
||||
(set! is-dim? (and v #t))
|
||||
(refresh))])]
|
||||
[orientation (lambda () (case rotated
|
||||
[(n) 0]
|
||||
[(e) 270]
|
||||
[(w) 90]
|
||||
[(s) 180]))]
|
||||
[rotate (lambda (mode)
|
||||
(let ([delta (case mode
|
||||
[(0 360) 0]
|
||||
[(cw -90 270) 1]
|
||||
[(ccw 90 -270) 3]
|
||||
[(180 -180) 2]
|
||||
[else (error 'rotate "bad mode: ~e" mode)])])
|
||||
(set! rotated (list-ref (find-head orientations rotated) delta))
|
||||
(if (odd? delta)
|
||||
(let ([w width])
|
||||
(set! width height)
|
||||
(set! height w)
|
||||
(refresh-size))
|
||||
(refresh))))]
|
||||
[get-suit-id
|
||||
(lambda () suit-id)]
|
||||
[get-suit
|
||||
(lambda ()
|
||||
(case suit-id
|
||||
[(1) 'clubs]
|
||||
[(2) 'diamonds]
|
||||
[(3) 'hearts]
|
||||
[(4) 'spades]
|
||||
[else 'unknown]))]
|
||||
[get-value
|
||||
(lambda () value)]
|
||||
[user-can-flip
|
||||
(case-lambda
|
||||
[() can-flip?]
|
||||
[(f) (set! can-flip? (and f #t))])]
|
||||
[user-can-move
|
||||
(case-lambda
|
||||
[() can-move?]
|
||||
[(f) (set! can-move? (and f #t))])]
|
||||
[snap-back-after-move
|
||||
(case-lambda
|
||||
[() snap-back?]
|
||||
[(f) (set! snap-back? (and f #t))])]
|
||||
[stay-in-region
|
||||
(case-lambda
|
||||
[() stay-region]
|
||||
[(r) (set! stay-region r)])]
|
||||
[home-region
|
||||
(case-lambda
|
||||
[() home-reg]
|
||||
[(r) (set! home-reg r)])]
|
||||
[card-width (lambda () width)]
|
||||
[card-height (lambda () height)])
|
||||
(override*
|
||||
[resize
|
||||
(lambda (w h) (void))]
|
||||
[get-extent
|
||||
(lambda (dc x y w h descent space lspace rspace)
|
||||
(map
|
||||
(lambda (b)
|
||||
(when b
|
||||
(set-box! b 0)))
|
||||
(list descent space lspace rspace))
|
||||
(when w (set-box! w width))
|
||||
(when h (set-box! h height)))]
|
||||
[draw
|
||||
(lambda (dc x y left top right bottom dx dy draw-caret)
|
||||
(check-dim)
|
||||
(let ([do-draw
|
||||
(lambda (x y)
|
||||
(send dc draw-bitmap
|
||||
(let ([bm (if flipped?
|
||||
(if is-dim? dim-back back)
|
||||
(if is-dim? dim-front front))])
|
||||
(get-rotated bm rotated))
|
||||
x y))])
|
||||
(if semi-flipped?
|
||||
(let-values ([(sx sy) (send dc get-scale)])
|
||||
(case rotated
|
||||
[(n s)
|
||||
(send dc set-scale (/ sx 2) sy)
|
||||
(do-draw (+ (* 2 x) (/ width 2)) y)
|
||||
(send dc set-scale sx sy)]
|
||||
[(e w)
|
||||
(send dc set-scale sx (/ sy 2))
|
||||
(do-draw x (+ (* 2 y) (/ height 2)))
|
||||
(send dc set-scale sx sy)]))
|
||||
(do-draw x y))))]
|
||||
[copy (lambda ()
|
||||
(let ([rotated? (memq rotated '(e w))])
|
||||
(make-object card% suit-id value
|
||||
(if rotated? height width)
|
||||
(if rotated? width height )
|
||||
front back
|
||||
(lambda ()
|
||||
(unless dim-front
|
||||
(set! dim-front (mk-dim-front)))
|
||||
dim-front)
|
||||
(lambda ()
|
||||
(unless dim-back
|
||||
(set! dim-back (mk-dim-back)))
|
||||
dim-back)
|
||||
rotated-bms)))])
|
||||
(define save-x (box 0))
|
||||
(define save-y (box 0))
|
||||
(public*
|
||||
[remember-location
|
||||
(lambda (pb)
|
||||
(send pb get-snip-location this save-x save-y))]
|
||||
[back-to-original-location
|
||||
(lambda (pb)
|
||||
(when snap-back?
|
||||
(send pb move-to this (unbox save-x) (unbox save-y)))
|
||||
(when home-reg
|
||||
(let ([xbox (box 0)]
|
||||
[ybox (box 0)])
|
||||
(send pb get-snip-location this xbox ybox #f)
|
||||
;; Completely in the region?
|
||||
(let* ([l (unbox xbox)]
|
||||
[rl (region-x home-reg)]
|
||||
[r (+ l width)]
|
||||
[rr (+ rl (region-w home-reg))]
|
||||
[t (unbox ybox)]
|
||||
[rt (region-y home-reg)]
|
||||
[b (+ t height)]
|
||||
[rb (+ rt (region-h home-reg))])
|
||||
(when (or (< l rl) (> r rr)
|
||||
(< t rt) (> b rb))
|
||||
;; Out of the region - completely or partly?
|
||||
(if (and (or (<= rl l rr) (<= rl r rr))
|
||||
(or (<= rt t rb) (<= rt b rb)))
|
||||
;; Just slightly out
|
||||
(send pb move-to this
|
||||
(min (max l rl) (- rr width))
|
||||
(min (max t rt) (- rb height)))
|
||||
;; Completely out
|
||||
(send pb move-to this (unbox save-x) (unbox save-y))))))))])
|
||||
|
||||
(super-make-object)
|
||||
(set-count 1)
|
||||
(set-snipclass sc)
|
||||
(flip))))
|
||||
|
||||
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
(module cards racket
|
||||
(require "base.rkt"
|
||||
"utils.rkt"
|
||||
"region.rkt")
|
||||
|
||||
(provide table<%> card<%>
|
||||
region struct:region
|
||||
make-region
|
||||
region? region-x region-y region-w region-h
|
||||
region-label region-callback region-interactive-callback
|
||||
set-region-callback!
|
||||
set-region-interactive-callback!
|
||||
make-button-region
|
||||
make-background-region
|
||||
|
||||
make-deck make-card
|
||||
make-table
|
||||
|
||||
shuffle-list))
|
||||
|
|
@ -1,517 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
(for-label games/cards
|
||||
racket/gui/base))
|
||||
|
||||
@title{Cards: Virtual Playing Cards Library}
|
||||
|
||||
@defmodule[games/cards]{The @racketmodname[games/cards]
|
||||
module provides a toolbox for creating card games.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Creating Tables and Cards}
|
||||
|
||||
@defproc[(make-table [title string? "Cards"]
|
||||
[w exact-nonnegative-integer? 7]
|
||||
[h exact-nonnegative-integer? 3])
|
||||
table<%>]{
|
||||
|
||||
Returns a table. The table is named by @racket[title], and it is
|
||||
@racket[w] cards wide and @racket[h] cards high (assuming a standard
|
||||
card of 71 by 96 pixels). The table is not initially shown;
|
||||
@racket[(send table show #t)] shows it.}
|
||||
|
||||
@defproc[(make-deck)
|
||||
(listof card<%>)]{
|
||||
|
||||
Returns a list of 52 cards, one for each suit-value combination. The
|
||||
cards are all face-down, sorted lowest-suit then lowest-value. A card
|
||||
can only be on one table at a time.}
|
||||
|
||||
@defproc[(make-card [front-bm (is-a?/c bitmap?)]
|
||||
[back-bm (or/c (is-a?/c bitmap%) false/c)]
|
||||
[suit-id any/c]
|
||||
[value any/c])
|
||||
(is-a?/c card<%>)]{
|
||||
|
||||
Returns a single card given a bitmap for the front, an optional bitmap
|
||||
for the back, and arbitrary values for the card's suit and value
|
||||
(which are returned by the card's @method[card<%> get-value] and
|
||||
@method[card<%> get-suit-id] methods). All provided bitmaps should be
|
||||
the same size.}
|
||||
|
||||
@defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?])
|
||||
list?]{
|
||||
|
||||
Shuffles the given @racket[lst] @racket[n] times, returning the new
|
||||
list. Shuffling simulates an actual shuffle: the list is split into
|
||||
halves which are merged back together by repeatedly pulling the top
|
||||
card off one of the halves, randomly selecting one half or the
|
||||
other. According to some mathematical theorem, 7 is a large enough
|
||||
@racket[n] to get a perfect shuffle.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Regions and Buttons}
|
||||
|
||||
@defstruct[region ([x real?]
|
||||
[y real?]
|
||||
[w (and/c real? (not/c negative?))]
|
||||
[h (and/c real? (not/c negative?))]
|
||||
[label (or/c string? false/c)]
|
||||
[(callback #:mutable) (or/c ((listof (is-a?/c card<%>)) . -> . any)
|
||||
false/c)])]{
|
||||
|
||||
The @racket[x], @racket[y], @racket[w], and @racket[h] fields
|
||||
determine the region's location on the table.
|
||||
|
||||
When @racket[label] is a string, it is drawn in the region in 12-pixel
|
||||
text, centered horizontally and 5 pixels down from the region's top
|
||||
outline. If label is @racket[#f], no label or box is drawn for the
|
||||
region.
|
||||
|
||||
The @racket[callback] procedure takes a list of cards that were
|
||||
dragged to the region; if callback is @racket[#f], the region is not
|
||||
active (i.e., dragging cards to the region doesn't highlight the
|
||||
region box). The region remains hilited until the callback returns.
|
||||
|
||||
The only available mutator on the structure is
|
||||
@racket[set-region-callback!]. The structure created by
|
||||
@racket[make-region] actually has extra hidden fields.}
|
||||
|
||||
@defproc[(make-button-region [x real?]
|
||||
[y real?]
|
||||
[w (and/c real? (not/c negative?))]
|
||||
[h (and/c real? (not/c negative?))]
|
||||
[label (or/c string? false/c)]
|
||||
[callback (or/c ((listof (is-a?/c card<%>)) . -> . any)
|
||||
false/c)])
|
||||
region?]{
|
||||
|
||||
Returns a region like one made by @racket[make-region], but the is
|
||||
drawn slightly differently and it reacts differently to cards and the
|
||||
mouse. The label is drawn in the middle of the box instead of at the
|
||||
top, and the callback is called with no arguments when the user
|
||||
clicks the region (instead of dragging cards to the region).}
|
||||
|
||||
@defproc[(make-background-region [x real?]
|
||||
[y real?]
|
||||
[w (and/c real? (not/c negative?))]
|
||||
[h (and/c real? (not/c negative?))]
|
||||
[paint-callback
|
||||
((is-a?/c dc<%>) real? real? real? real? . -> . any)])
|
||||
region?]{
|
||||
|
||||
Returns a region that does not respond to mouse clicks, but which has
|
||||
a general paint callback. The @racket[paint-callback] function is
|
||||
called with a drawing context, x and y offsets, and the width and
|
||||
height (which are always @racket[w] and @racket[h]). The x and y
|
||||
offsets can be different than the supplied @racket[x] and @racket[y]
|
||||
when part of the table is drawn offscreen. Regions are painted in the
|
||||
order that they are added to a table, and all regions are painted
|
||||
before any card. The @racket[paint-callback] procedure should not
|
||||
assume a particular state for the drawing context (i.e.,current brush
|
||||
or pen), and it should restore any modified drawing context state
|
||||
before returning.}
|
||||
|
||||
@defproc[(set-region-interactive-callback!
|
||||
[r region?]
|
||||
[callback (or/c (boolean? (listof (is-a?/c card<%>)) . -> . any)
|
||||
false/c)])
|
||||
void?]{
|
||||
|
||||
Sets a callback procedure that is invoked when a region is
|
||||
(un)hilited as the user drags a set of cards to the region. The
|
||||
callback is provided two arguments: a boolean indicating whether the
|
||||
region is hilited, and the list of cards being dragged. Like
|
||||
region-callback, the default is @racket[#f], which indicates that the
|
||||
region has no interactive callback (but does not affect whether the
|
||||
region is hilited as cards are dragged). The final unhilite (when
|
||||
cards are potentially delivered) does not trigger this callback.}
|
||||
|
||||
|
||||
@defproc[(region-interactive-callback [r region?])
|
||||
(boolean? (listof (is-a?/c card<%>)) . -> . any)]{
|
||||
|
||||
Gets the current callback that is installed via
|
||||
@racket[set-region-interaction-callback!].}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Table Methods}
|
||||
|
||||
@definterface[table<%> (frame%)]{
|
||||
|
||||
Create an instance with @racket[make-table].
|
||||
|
||||
@defmethod[(add-card [card (is-a?/c card<%>)]
|
||||
[x real?]
|
||||
[y real?])
|
||||
void?]{
|
||||
|
||||
Adds @racket[card] to the table with its top-left corner at
|
||||
(@racket[x], @racket[y]) in table pixels.}
|
||||
|
||||
@defmethod[(add-cards [cards (listof (is-a?/c card<%>))]
|
||||
[x real?]
|
||||
[y real?]
|
||||
[offset-proc (exact-nonnegative-integer?
|
||||
. -> . (values real? real?))
|
||||
(lambda (i) (values 0 0))])
|
||||
void?]{
|
||||
|
||||
Adds a list of cards at (@racket[x], @racket[y]). The optional
|
||||
@racket[offset-proc] procedure is called with an index @racket[_i]
|
||||
(counting from 0) and should return two values: @racket[_dx] and
|
||||
@racket[_dy]; the @racket[_i]th card is the placed at @racket[(+ x
|
||||
+dx)] and @racket[(+ y _dy)]. The cards are added in order on top of
|
||||
cards already one the table such that the first card in
|
||||
@racket[cards] is topmost.}
|
||||
|
||||
@defmethod[(add-cards-to-region [cards (listof (is-a?/c card<%>))]
|
||||
[region? r])
|
||||
void?]{
|
||||
|
||||
Adds @racket[cards] to fill the region @racket[r], fanning them out
|
||||
bottom-right to top-left, assuming that all cards in @racket[cards]
|
||||
have the same width and height. The region @racket[r] does not have
|
||||
to be added to the table.}
|
||||
|
||||
@defmethod[(remove-card [card (is-a?/c card<%>)])
|
||||
void?]{
|
||||
|
||||
Removes @racket[card] from the table.}
|
||||
|
||||
@defmethod[(remove-cards [cards (listof (is-a?/c card<%>))])
|
||||
void?]{
|
||||
|
||||
Removes @racket[cards] from the table.}
|
||||
|
||||
@defmethod[(move-card [card (is-a?/c card<%>)]
|
||||
[x real?]
|
||||
[y real?])
|
||||
void?]{
|
||||
|
||||
Moves @racket[card], which must be on the same already. The movement
|
||||
of the cards is animated. If the cards are in snap-back-after-move
|
||||
mode and a drag is active, snapping back will use the new location.}
|
||||
|
||||
@defmethod[(move-cards [cards (listof (is-a?/c card<%>))]
|
||||
[x real?]
|
||||
[y real?]
|
||||
[offset-proc (exact-nonnegative-integer?
|
||||
. -> . (values real? real?))
|
||||
(lambda (i) (values 0 0))])
|
||||
void?]{
|
||||
|
||||
Like @method[table<%> add-cards], but moves cards that are already on
|
||||
the table like @method[table<%> move-card]. All of the cards are
|
||||
moved at once.}
|
||||
|
||||
@defmethod[(move-cards-to-region [cards (listof (is-a?/c card<%>))]
|
||||
[region? r])
|
||||
void?]{
|
||||
|
||||
Like @method[table<%> add-cards-to-region], but moves cards that are
|
||||
already on the table like @racket[move-card]. All of the cards are
|
||||
moved at once.}
|
||||
|
||||
|
||||
@defmethod*[([(flip-card [card (is-a?/c card<%>)]) void?]
|
||||
[(flip-cards [cards (listof (is-a?/c card<%>))]) void?])]{
|
||||
|
||||
Flips @racket[card] or all @racket[cards] over (at once) with
|
||||
animation.}
|
||||
|
||||
@defmethod*[([(card-face-up [card (is-a?/c card<%>)]) void?]
|
||||
[(cards-face-up [cards (listof (is-a?/c card<%>))]) void?]
|
||||
[(card-face-down [card (is-a?/c card<%>)]) void?]
|
||||
[(cards-face-down [cards (listof (is-a?/c card<%>))]) void?])]{
|
||||
|
||||
Like @method[table<%> flip-cards], but only for @racket[card] or
|
||||
elements of @racket[cards] that are currently face down/up.}
|
||||
|
||||
@defmethod*[([(rotate-card [card (is-a?/c card<%>)]
|
||||
[mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)])
|
||||
void?]
|
||||
[(rotate-cards [cards (listof (is-a?/c card<%>))]
|
||||
[mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)])
|
||||
void?])]{
|
||||
|
||||
Rotates @racket[card] or all @racket[cards] (at once, currently
|
||||
without animation, but animation may be added in the future).
|
||||
The center of each card is kept in place, except that the card is
|
||||
moved as necessary to keep it on the table. See @xmethod[card<%>
|
||||
rotate] for information on @racket[mode].}
|
||||
|
||||
@defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?]
|
||||
[(card-to-back [card (is-a?/c card<%>)]) void?])]{
|
||||
|
||||
Moves @racket[card] before/behind of all other cards.}
|
||||
|
||||
@defmethod[(stack-cards [cards (listof (is-a?/c card<%>))]) void?]{
|
||||
|
||||
The first card in @racket[cards] is not moved; the second card is
|
||||
moved to follow immediately behind the first one, then
|
||||
@method[table<%> stack-cards] is called on @racket[(cdr cards)]. If
|
||||
@racket[cards] is empty or contains only one card, no action is
|
||||
taken.}
|
||||
|
||||
@defmethod[(card-location [card (is-a?/c card<%>)])
|
||||
(values real? real?)]{
|
||||
|
||||
Returns the location of the given card; an exception is raised if the
|
||||
card is not on the table.}
|
||||
|
||||
@defmethod[(all-cards) (listof (is-a?/c card<%>))]{
|
||||
|
||||
Returns a list of all cards on the table in stacking order from front
|
||||
to back.}
|
||||
|
||||
@defmethod*[([(table-width) exact-nonnegative-integer?]
|
||||
[(table-height) exact-nonnegative-integer?])]{
|
||||
|
||||
Returns the width/height of the table in pixels.}
|
||||
|
||||
@defmethod*[([(begin-card-sequence) void?]
|
||||
[(end-card-sequence) void?])]{
|
||||
|
||||
Starts/ends a sequence of card or region changes that won't be
|
||||
animated or updated until the end of the sequence. Sequences can be
|
||||
nested via matching @racketidfont{begin-}/@racketidfont{end-} pairs.}
|
||||
|
||||
@defmethod[(add-region [r region?]) void]{
|
||||
|
||||
Adds the region @racket[r] to the table; regions are drawn in the
|
||||
order that they are added to the table, and when a region added later
|
||||
is hilighted, it can obscure regions added earlier.}
|
||||
|
||||
@defmethod[(remove-region [r region?]) void]{
|
||||
|
||||
Removes the region @racket[r] from the table.}
|
||||
|
||||
@defmethod*[([(hilite-region [r region?]) void?]
|
||||
[(unhilite-region [r region?]) void?])]{
|
||||
|
||||
Manual (un)hilite, usually for animation.}
|
||||
|
||||
@defmethod[(set-button-action [which (one-of/c 'left 'middle 'right)]
|
||||
[action symbol?])
|
||||
void?]{
|
||||
|
||||
Sets the way that a mouse click is handled for a particular button
|
||||
indicated by @racket[which]. The @racket[action] argument must be one
|
||||
of the following:
|
||||
|
||||
@itemize[
|
||||
|
||||
@item{@racket['drag/one] --- drag only the clicked-on card.}
|
||||
|
||||
@item{@racket['drag-raise/one] --- like drag/one, but raise the
|
||||
card to the top on a click.}
|
||||
|
||||
@item{@racket['drag/above] --- drag the card along with any card
|
||||
on top of the card (i.e., more towards the front and
|
||||
overlapping with the card). The on-top-of relation
|
||||
is closed transitively.}
|
||||
|
||||
@item{@racket['drag-raise/above] --- like @racket['drag/above],
|
||||
but raises.}
|
||||
|
||||
@item{@racket['drag-below] --- drag the card along with any card
|
||||
underneath the card (i.e., more towards the back and
|
||||
overlapping with the card). The underneath relation
|
||||
is closed transitively.}
|
||||
|
||||
@item{@racket['drag-raise/below] --- like @racket['drag/below],
|
||||
but raises.}
|
||||
]
|
||||
|
||||
The initial settings are: @racket['drag-raise/above] for
|
||||
@racket['left], @racket['drag/one] for @racket['middle], and
|
||||
@racket['drag/below] for @racket['right].}
|
||||
|
||||
@defmethod[(set-double-click-action
|
||||
[proc ((is-a?/c card<%>) . -> . any)])
|
||||
void?]{
|
||||
|
||||
Sets the procedure to be called when a card is double-clicked. The
|
||||
procedure is called with the double-clicked card. The default
|
||||
procedure flips the cards along with its on-top-of cards, raises the
|
||||
cards, and reverses the front-to-back order of the cards}
|
||||
|
||||
@defmethod[(set-single-click-action
|
||||
[proc ((is-a?/c card<%>) . -> . any)])
|
||||
void?]{
|
||||
|
||||
Sets the procedure to be called when a card is single-clicked, after
|
||||
the button action is initiated. (If the card is double-clicked, this
|
||||
action is invoked for the first click, then the double-click action
|
||||
is invoked.) The default action does nothing.}
|
||||
|
||||
@defmethod[(pause [secs real?]) void?]{
|
||||
|
||||
Pauses, allowing the table display to be updated (unless a sequence
|
||||
is active), but does not let the user click on the cards.}
|
||||
|
||||
@defmethod*[([(animated) boolean?]
|
||||
[(animated [on? any/c]) void?])]{
|
||||
|
||||
Gets/sets animation enabled/diabled.}
|
||||
|
||||
@defmethod[(create-status-pane) (is-a?/c pane%)]{
|
||||
|
||||
Creates a pane with a status message (initially empty) and returns
|
||||
the pane so that you can add additional controls.}
|
||||
|
||||
@defmethod[(set-status [str sring]) void?]{
|
||||
|
||||
Sets the text message in the status pane.}
|
||||
|
||||
@defmethod[(add-help-button [pane (is-a?/c area-container<%>)]
|
||||
[coll-path (listof string?)]
|
||||
[str string?]
|
||||
[tt? any/c])
|
||||
void?]{
|
||||
|
||||
Adds a @onscreen{Help} button to the given pane, where clicking the
|
||||
button opens a new window to display @filepath{doc.txt} from the given
|
||||
collection. The @racket[str] argument is used for the help window
|
||||
title. If @racket[tt?] is true, then @filepath{doc.txt} is displayed
|
||||
verbatim, otherwise it is formatted as for @racket[show-help] from
|
||||
@racketmodname[games/show-help].}
|
||||
|
||||
@defmethod[(add-scribble-button [pane (is-a?/c area-container<%>)]
|
||||
[mod-path module-path?]
|
||||
[tag string?])
|
||||
void?]{
|
||||
|
||||
Adds a @onscreen{Help} button to the given pane, where clicking the
|
||||
button opens Scribble-based documentation, as with
|
||||
@racket[show-scribbling] from @racketmodname[games/show-scribbling].}
|
||||
|
||||
}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
@section{Card Methods}
|
||||
|
||||
@definterface[card<%> ()]{
|
||||
|
||||
Create instances with @racket[make-deck] or @racket[make-card].
|
||||
|
||||
@defmethod[(card-width) exact-nonnegative-integer?]{
|
||||
|
||||
Returns the width of the card in pixels. If the card is rotated 90 or
|
||||
270 degrees, the result is the card's original height.}
|
||||
|
||||
@defmethod[(card-height) exact-nonnegative-integer?]{
|
||||
|
||||
Returns the height of the card in pixels. If the card is rotated 90 or
|
||||
270 degrees, the result is the card's original width.}
|
||||
|
||||
@defmethod[(flip) void?]{
|
||||
|
||||
Flips the card without animation. This method is useful for flipping
|
||||
a card before it is added to a table.}
|
||||
|
||||
@defmethod[(face-up) void?]{
|
||||
|
||||
Makes the card face up without animation.}
|
||||
|
||||
@defmethod[(face-down) void?]{
|
||||
|
||||
Makes the card face down without animation.}
|
||||
|
||||
@defmethod[(face-down?) boolean?]{
|
||||
|
||||
Returns @racket[#t] if the card is currently face down.}
|
||||
|
||||
@defmethod[(rotate [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) void?]{
|
||||
|
||||
Rotates the card. Unlike using the @xmethod[table<%> rotate-card] method,
|
||||
the card's top-left position is kept in place.
|
||||
|
||||
If @racket[mode] is @racket['cw], the card is
|
||||
rotated clockwise; if @racket[mode] is @racket['ccw], the card is
|
||||
rotated counter-clockwise; if @racket[mode] is one of the allowed
|
||||
numbers, the card is rotated the corresponding amount in degrees
|
||||
counter-clockwise.}
|
||||
|
||||
@defmethod[(orientation) (or/c 0 90 180 270)]{
|
||||
|
||||
Returns the orientation of the card, where @racket[0] corresponds to
|
||||
its initial state, @racket[90] is rotated 90 degrees counter-clockwise, and so on.}
|
||||
|
||||
@defmethod[(get-suit-id) any/c]{
|
||||
|
||||
Normally returns @racket[1], @racket[2], @racket[3], or @racket[4]
|
||||
(see @method[card<%> get-suit] for corresponding suit names), but the
|
||||
result can be anything for a card created by @racket[make-card].}
|
||||
|
||||
@defmethod[(get-suit) symbol?]{
|
||||
|
||||
Returns @racket['clubs], @racket['diamonds], @racket['hearts],
|
||||
@racket['spades], or @racket['unknown], depending on whether
|
||||
@method[card<%> get-suit-id] returns @racket[1], @racket[2],
|
||||
@racket[3], @racket[4], or something else.}
|
||||
|
||||
@defmethod[(get-value) any/c]{
|
||||
|
||||
Normally returns @racket[1] (Ace), @racket[2], ... @racket[10],
|
||||
@racket[11] (Jack), @racket[12] (Queen), or @racket[13] (King), but
|
||||
the result can be anything for a card created by @racket[make-card].}
|
||||
|
||||
@defmethod*[([(user-can-flip) boolean?]
|
||||
[(user-can-flip [can? any/c]) void?])]{
|
||||
|
||||
Gets/sets whether the user can flip the card interactively, usually
|
||||
by double-clicking it. Initially @racket[#t].}
|
||||
|
||||
@defmethod*[([(user-can-move) boolean?]
|
||||
[(user-can-move [can? any/c]) void?])]{
|
||||
|
||||
Gets/sets whether the user can move the card interactively, usually
|
||||
by dragging it. Disabling moves has the side-effect of disabling
|
||||
raises and double-clicks. Initially @racket[#t].}
|
||||
|
||||
@defmethod*[([(snap-back-after-move) boolean?]
|
||||
[(snap-back-after-move [on? any/c]) void?])]{
|
||||
|
||||
Assuming user can move the card interactively, gets/sets whether the
|
||||
card stays where the user dragged it or snaps back to its original
|
||||
place. Initially @racket[#f].
|
||||
|
||||
A region's @italic{interactive} callback can disable snap-back for a
|
||||
card so that the card can be delivered to the region. (A region's
|
||||
normal callback cannot release the card, because it's too late.)}
|
||||
|
||||
@defmethod*[([(stay-in-region) (or/c region? false/c)]
|
||||
[(stay-in-region [r (or/c region? false/c)]) void?])]{
|
||||
|
||||
|
||||
Gets/sets a constraining region @racket[r]. If @racket[r] is not
|
||||
@racket[#f], the user cannot move the card out of @racket[r].
|
||||
Initially @racket[#f].}
|
||||
|
||||
@defmethod*[([(home-region) (or/c region? false/c)]
|
||||
[(home-region [r (or/c region? false/c)]) void?])]{
|
||||
|
||||
Gets/sets a home region @racket[r]. If @racket[r] is not @racket[#f],
|
||||
then the user can move the card freely within the region, but it
|
||||
snaps back if moved completely out of the region. If moved partly out
|
||||
of the region, the card is moved enough to get completely back
|
||||
in. Initially @racket[#f].
|
||||
|
||||
A region's @italic{interactive} callback can disable snap-back for a
|
||||
card so that the card can be delivered to the region. (A region's
|
||||
normal callback cannot release the card, because it's too late.)}
|
||||
|
||||
@defmethod*[([(dim) boolean?]
|
||||
[(dim [can? any/c]) void?])]{
|
||||
|
||||
Gets/sets a hilite on the card, which is rendered by drawing it dimmer
|
||||
than normal.}
|
||||
|
||||
@defmethod[(copy) (is-a?/c card<%>)]{
|
||||
|
||||
Makes a new card with the same suit and value.}
|
||||
|
||||
}
|
||||
|
|
@ -1,752 +0,0 @@
|
|||
(module classes racket/base
|
||||
(require racket/class
|
||||
(prefix-in mred: racket/gui)
|
||||
(prefix-in util: "utils.rkt")
|
||||
"constants.rkt"
|
||||
"make-cards.rkt"
|
||||
"region.rkt"
|
||||
string-constants
|
||||
"../show-help.rkt"
|
||||
"../show-scribbling.rkt")
|
||||
|
||||
(provide pasteboard%
|
||||
table%)
|
||||
|
||||
(define pasteboard%
|
||||
(class mred:pasteboard%
|
||||
(inherit begin-edit-sequence end-edit-sequence get-admin
|
||||
invalidate-bitmap-cache
|
||||
find-next-selected-snip find-first-snip find-snip
|
||||
set-before set-after
|
||||
add-selected is-selected? no-selected set-selected remove-selected
|
||||
get-snip-location move-to
|
||||
dc-location-to-editor-location
|
||||
set-selection-visible)
|
||||
|
||||
(define select-one? #t)
|
||||
(define select-backward? #f)
|
||||
(define raise-to-front? #f)
|
||||
(define button-map '((left #f #f #t)
|
||||
(middle #t #f #t)
|
||||
(right #f #t #f)))
|
||||
|
||||
(define do-on-double-click 'flip)
|
||||
(define do-on-single-click void)
|
||||
|
||||
(define selecting? #f)
|
||||
(define dragging? #f)
|
||||
(define bg-click? #f)
|
||||
(define click-base #f)
|
||||
(define last-click #f)
|
||||
(define regions null)
|
||||
(private*
|
||||
[get-snip-bounds
|
||||
(lambda (s)
|
||||
(let ([xbox (box 0)]
|
||||
[ybox (box 0)])
|
||||
(get-snip-location s xbox ybox #f)
|
||||
(let ([l (unbox xbox)]
|
||||
[t (unbox ybox)])
|
||||
(get-snip-location s xbox ybox #t)
|
||||
(values l t (unbox xbox) (unbox ybox)))))]
|
||||
[for-each-selected
|
||||
(lambda (f)
|
||||
(let loop ([snip (find-next-selected-snip #f)])
|
||||
(when snip
|
||||
(f snip)
|
||||
(loop (find-next-selected-snip snip)))))]
|
||||
[make-overlapping-list
|
||||
(lambda (s so-far behind?)
|
||||
(let-values ([(sl st sr sb) (get-snip-bounds s)])
|
||||
(let loop ([t (find-first-snip)][so-far so-far][get? (not behind?)])
|
||||
(cond
|
||||
[(not t) so-far]
|
||||
[(eq? s t) (if behind?
|
||||
(loop (send t next) so-far #t)
|
||||
so-far)]
|
||||
[get?
|
||||
(let ([l (if (and (not (memq t so-far))
|
||||
(let-values ([(tl tt tr tb)
|
||||
(get-snip-bounds t)])
|
||||
(and (or (<= sl tl sr)
|
||||
(<= sl tr sr))
|
||||
(or (<= st tt sb)
|
||||
(<= st tb sb)))))
|
||||
(make-overlapping-list t (cons t so-far) behind?)
|
||||
so-far)])
|
||||
(loop (send t next) l #t))]
|
||||
[else
|
||||
(loop (send t next) so-far #f)]))))]
|
||||
[get-reverse-selected-list
|
||||
(lambda ()
|
||||
(let loop ([s (find-next-selected-snip #f)][l null])
|
||||
(if s
|
||||
(loop (find-next-selected-snip s) (cons s l))
|
||||
l)))]
|
||||
[shuffle
|
||||
(lambda (selected-list) ; cards to shuffle in back->front order
|
||||
(let* ([permuted-list
|
||||
(util:shuffle-list selected-list 7)]
|
||||
[get-pos
|
||||
(lambda (s)
|
||||
(let ([xb (box 0)]
|
||||
[yb (box 0)])
|
||||
(get-snip-location s xb yb)
|
||||
(cons (unbox xb) (unbox yb))))]
|
||||
[sel-loc-list (map get-pos selected-list)]
|
||||
[perm-loc-list (map get-pos permuted-list)])
|
||||
(for-each
|
||||
(lambda (s start-pos end-pos)
|
||||
(let* ([sx (car start-pos)]
|
||||
[sy (cdr start-pos)]
|
||||
[ex (car end-pos)]
|
||||
[ey (cdr end-pos)]
|
||||
[steps (max 1 (floor (/ 50 (length selected-list))))])
|
||||
(let loop ([i 1])
|
||||
(unless (> i steps)
|
||||
(let ([x (+ sx (* (/ i steps) (- ex sx)))]
|
||||
[y (+ sy (* (/ i steps) (- ey sy)))])
|
||||
(move-to s x y)
|
||||
(mred:flush-display)
|
||||
(loop (add1 i)))))))
|
||||
permuted-list perm-loc-list sel-loc-list)
|
||||
(let loop ([l permuted-list])
|
||||
(unless (null? l)
|
||||
(set-before (car l) #f)
|
||||
(loop (cdr l))))
|
||||
(no-selected)))]
|
||||
[update-region
|
||||
(lambda (region)
|
||||
(let-values ([(sx sy sw sh) (get-region-box region)])
|
||||
(invalidate-bitmap-cache sx sy sw sh)))])
|
||||
(public*
|
||||
[only-front-selected
|
||||
(lambda ()
|
||||
(let loop ([s (find-next-selected-snip #f)][ok (find-first-snip)])
|
||||
(when s
|
||||
(if (eq? s ok)
|
||||
(loop (find-next-selected-snip s)
|
||||
(send ok next))
|
||||
(let loop ([s s][l (list s)])
|
||||
(let ([next (find-next-selected-snip s)])
|
||||
(if next
|
||||
(loop next (cons s l))
|
||||
(for-each (lambda (s)
|
||||
(remove-selected s))
|
||||
l))))))))])
|
||||
(override*
|
||||
[on-paint
|
||||
(lambda (before? dc l t r b dx dy caret)
|
||||
(when before?
|
||||
(for-each
|
||||
(lambda (region)
|
||||
(when (region-paint-callback region)
|
||||
(let-values ([(sx sy sw sh) (get-region-box region)])
|
||||
((region-paint-callback region) dc (+ dx sx) (+ dy sy) sw sh)))
|
||||
(when (region-label region)
|
||||
(let ([old-b (send dc get-brush)]
|
||||
[old-p (send dc get-pen)])
|
||||
(let-values ([(sx sy sw sh) (get-region-box region)])
|
||||
(send dc set-brush white-brush)
|
||||
(send dc set-pen no-pen)
|
||||
(send dc draw-rectangle (+ dx sx) (+ dy sy) sw sh)
|
||||
(send dc set-pen dark-gray-pen)
|
||||
(draw-roundish-rectangle dc (+ dx sx) (+ dy sy) sw sh)
|
||||
(let ([text (region-label region)])
|
||||
(if (string? text)
|
||||
(let ([old-f (send dc get-font)])
|
||||
(send dc set-font nice-font)
|
||||
(let-values ([(x y d a) (send dc get-text-extent text)])
|
||||
(send dc draw-text text
|
||||
(+ dx sx (/ (- sw x) 2))
|
||||
(if (region-button? region)
|
||||
;; Since we use size-in-pixels, the letters
|
||||
;; should really be 12 pixels high (including
|
||||
;; the descender), but the space above the letter
|
||||
;; can vary by font; center on 12, splitting
|
||||
;; the difference for the descender
|
||||
(+ dy sy (/ (- sh 12) 2) (- 12 y (/ d -2)))
|
||||
(+ dy sy 5))))
|
||||
(send dc set-font old-f))
|
||||
(send dc draw-bitmap text
|
||||
(+ dx sx (/ (- sw (send text get-width)) 2))
|
||||
(+ dy sy (/ (- sh (send text get-height)) 2))
|
||||
'solid black-color
|
||||
(send text get-loaded-mask))))
|
||||
(when (region-hilite? region)
|
||||
(send dc set-brush hilite-brush)
|
||||
(send dc set-pen no-pen)
|
||||
(send dc draw-rectangle (+ dx sx 1) (+ dy sy 1) (- sw 2) (- sh 2))))
|
||||
(send dc set-brush old-b)
|
||||
(send dc set-pen old-p))))
|
||||
regions)))])
|
||||
(augment*
|
||||
[after-select
|
||||
(lambda (s on?)
|
||||
(inner (void) after-select s on?)
|
||||
(unless (or (not on?) selecting?)
|
||||
(set! selecting? #t)
|
||||
(if select-one?
|
||||
(when raise-to-front?
|
||||
(set-before s #f))
|
||||
(begin
|
||||
(begin-edit-sequence)
|
||||
(let ([l (make-overlapping-list s (list s) select-backward?)])
|
||||
(for-each (lambda (i) (add-selected i)) l))
|
||||
(when raise-to-front?
|
||||
(let loop ([snip (find-next-selected-snip #f)][prev #f])
|
||||
(when snip
|
||||
(if prev
|
||||
(set-after snip prev)
|
||||
(set-before snip #f))
|
||||
(loop (find-next-selected-snip snip) snip))))
|
||||
(end-edit-sequence)))
|
||||
(set! selecting? #f)))]
|
||||
[on-interactive-move
|
||||
(lambda (e)
|
||||
(inner (void) on-interactive-move e)
|
||||
(for-each (lambda (region) (set-region-decided-start?! region #f)) regions)
|
||||
(for-each-selected (lambda (snip) (send snip remember-location this)))
|
||||
(set! dragging? #t))])
|
||||
(override*
|
||||
[interactive-adjust-move
|
||||
(lambda (snip xb yb)
|
||||
(super interactive-adjust-move snip xb yb)
|
||||
(let-values ([(l t r b) (get-snip-bounds snip)])
|
||||
(let-values ([(rl rt rw rh)
|
||||
(let ([r (send snip stay-in-region)])
|
||||
(if r
|
||||
(values (region-x r) (region-y r)
|
||||
(region-w r) (region-h r))
|
||||
(let ([wb (box 0)][hb (box 0)])
|
||||
(send (get-admin) get-view #f #f wb hb)
|
||||
(values 0 0 (unbox wb) (unbox hb)))))])
|
||||
(let ([max-x (- (+ rl rw) (- r l))]
|
||||
[max-y (- (+ rt rh) (- b t))])
|
||||
(when (< (unbox xb) rl)
|
||||
(set-box! xb rl))
|
||||
(when (> (unbox xb) max-x)
|
||||
(set-box! xb max-x))
|
||||
(when (< (unbox yb) rt)
|
||||
(set-box! yb rt))
|
||||
(when (> (unbox yb) max-y)
|
||||
(set-box! yb max-y))))))])
|
||||
(augment*
|
||||
[after-interactive-move
|
||||
(lambda (e)
|
||||
(when dragging?
|
||||
(set! dragging? #f)
|
||||
(inner (void) after-interactive-move e)
|
||||
(for-each-selected (lambda (snip) (send snip back-to-original-location this)))
|
||||
(let ([cards (get-reverse-selected-list)])
|
||||
(only-front-selected) ; in case overlap changed
|
||||
(for-each
|
||||
(lambda (region)
|
||||
(when (region-hilite? region)
|
||||
(mred:queue-callback
|
||||
; Call it outside the current edit sequence
|
||||
(lambda ()
|
||||
((region-callback region) cards)
|
||||
(unhilite-region region)))))
|
||||
regions))))])
|
||||
(override*
|
||||
[on-default-event
|
||||
(lambda (e)
|
||||
(let ([click (let ([c (or (and (send e button-down? 'left) 'left)
|
||||
(and (send e button-down? 'right) 'right)
|
||||
(and (send e button-down? 'middle) 'middle))])
|
||||
(cond
|
||||
[(eq? c last-click) c]
|
||||
[(not last-click) c]
|
||||
;; Move/drag event has different mouse button,
|
||||
;; and there was no mouse up. Don't accept the
|
||||
;; click, yet.
|
||||
[else #f]))])
|
||||
(set! last-click click)
|
||||
(when click
|
||||
(let* ([actions (cdr (assoc click button-map))]
|
||||
[one? (list-ref actions 0)]
|
||||
[backward? (list-ref actions 1)]
|
||||
[raise? (list-ref actions 2)])
|
||||
(unless (and (eq? backward? select-backward?)
|
||||
(eq? one? select-one?)
|
||||
(eq? raise? raise-to-front?))
|
||||
(set! select-one? one?)
|
||||
(set! select-backward? backward?)
|
||||
(set! raise-to-front? raise?)
|
||||
(no-selected))))
|
||||
(let*-values ([(lx ly) (dc-location-to-editor-location
|
||||
(send e get-x)
|
||||
(send e get-y))]
|
||||
[(s) (find-snip lx ly)])
|
||||
; Clicking on a "selected" card unselects others
|
||||
; in this interface
|
||||
(when (send e button-down?)
|
||||
(unless (or (not click-base) (not s) (eq? s click-base))
|
||||
(no-selected))
|
||||
(set! click-base s))
|
||||
(when (and dragging? click-base (send click-base user-can-move))
|
||||
(for-each
|
||||
(lambda (region)
|
||||
(when (and (not (region-button? region))
|
||||
(region-callback region)
|
||||
(or (not (region-decided-start? region))
|
||||
(region-can-select? region)))
|
||||
(let-values ([(sx sy sw sh) (get-region-box region)])
|
||||
(let ([in? (and (<= sx lx (+ sx sw))
|
||||
(<= sy ly (+ sy sh)))])
|
||||
(unless (region-decided-start? region)
|
||||
(set-region-decided-start?! region #t)
|
||||
(set-region-can-select?! region (not in?)))
|
||||
(when (and (not (eq? in? (region-hilite? region)))
|
||||
(region-can-select? region))
|
||||
(set-region-hilite?! region in?)
|
||||
(when (region-interactive-callback region)
|
||||
((region-interactive-callback region) in? (get-reverse-selected-list)))
|
||||
(invalidate-bitmap-cache sx sy sw sh))))))
|
||||
regions))
|
||||
; Can't move => no raise, either
|
||||
(unless (or (not click-base) (send click-base user-can-move))
|
||||
(set! raise-to-front? #f))
|
||||
(let ([was-bg? bg-click?])
|
||||
(if (send e button-down?)
|
||||
(set! bg-click? (not s))
|
||||
(when (and bg-click? (not (send e dragging?)))
|
||||
(set! bg-click? #f)))
|
||||
(unless bg-click?
|
||||
(super on-default-event e))
|
||||
(when (and bg-click? dragging?)
|
||||
;; We didn't call super on-default-event, so we need
|
||||
;; to explicitly end the drag:
|
||||
(after-interactive-move e))
|
||||
(when bg-click?
|
||||
; Check for clicking on a button region:
|
||||
(for-each
|
||||
(lambda (region)
|
||||
(when (and (region-button? region)
|
||||
(region-callback region))
|
||||
(let-values ([(sx sy sw sh) (get-region-box region)])
|
||||
(let ([in? (and (<= sx lx (+ sx sw))
|
||||
(<= sy ly (+ sy sh)))])
|
||||
(unless (region-decided-start? region)
|
||||
(set-region-decided-start?! region #t)
|
||||
(set-region-can-select?! region in?))
|
||||
(when (and (not (eq? in? (region-hilite? region)))
|
||||
(region-can-select? region))
|
||||
(set-region-hilite?! region in?)
|
||||
(invalidate-bitmap-cache sx sy sw sh))))))
|
||||
regions))
|
||||
(when (and was-bg? (not bg-click?))
|
||||
; Callback hilighted button:
|
||||
(for-each
|
||||
(lambda (region)
|
||||
(when (region-button? region)
|
||||
(set-region-decided-start?! region #f)
|
||||
(when (region-hilite? region)
|
||||
(mred:queue-callback
|
||||
; Call it outside the current edit sequence
|
||||
(lambda ()
|
||||
((region-callback region))
|
||||
(unhilite-region region))))))
|
||||
regions)))
|
||||
(when (and (send e button-down?)
|
||||
click-base
|
||||
(not (send click-base user-can-move)))
|
||||
(no-selected)))
|
||||
(when (and click click-base)
|
||||
(do-on-single-click click-base))))]
|
||||
[on-double-click
|
||||
(lambda (s e)
|
||||
(cond
|
||||
[(eq? do-on-double-click 'flip)
|
||||
(begin-edit-sequence)
|
||||
(let ([l (get-reverse-selected-list)])
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(when (send s user-can-flip)
|
||||
(send s flip)))
|
||||
l)
|
||||
(let loop ([l (reverse l)])
|
||||
(unless (null? l)
|
||||
(set-before (car l) #f)
|
||||
(loop (cdr l)))))
|
||||
(no-selected)
|
||||
(end-edit-sequence)]
|
||||
[do-on-double-click
|
||||
(do-on-double-click s)]
|
||||
[else (void)]))])
|
||||
(public*
|
||||
[get-all-list
|
||||
(lambda ()
|
||||
(let loop ([t (find-first-snip)][accum null])
|
||||
(cond
|
||||
[(not t) (reverse accum)]
|
||||
[else (loop (send t next) (cons t accum))])))]
|
||||
[get-full-box
|
||||
(lambda ()
|
||||
(let ([xb (box 0)][yb (box 0)]
|
||||
[wb (box 0)][hb (box 0)])
|
||||
(send (get-admin) get-view xb yb wb hb)
|
||||
(values 0 0 (unbox wb) (unbox hb))))]
|
||||
[get-region-box
|
||||
(lambda (region)
|
||||
(values (region-x region)
|
||||
(region-y region)
|
||||
(region-w region)
|
||||
(region-h region)))]
|
||||
[add-region
|
||||
(lambda (r)
|
||||
(set! regions (append regions (list r)))
|
||||
(update-region r))]
|
||||
[remove-region
|
||||
(lambda (r)
|
||||
(set! regions (remq r regions))
|
||||
(update-region r))]
|
||||
[unhilite-region
|
||||
(lambda (region)
|
||||
(set-region-hilite?! region #f)
|
||||
(update-region region))]
|
||||
[hilite-region
|
||||
(lambda (region)
|
||||
(set-region-hilite?! region #t)
|
||||
(update-region region))]
|
||||
[set-double-click-action
|
||||
(lambda (a)
|
||||
(set! do-on-double-click a))]
|
||||
[set-single-click-action
|
||||
(lambda (a)
|
||||
(set! do-on-single-click a))]
|
||||
[set-button-action
|
||||
(lambda (button action)
|
||||
(let ([map
|
||||
(case action
|
||||
[(drag/one) (list #t #f #f)]
|
||||
[(drag-raise/one) (list #t #f #t)]
|
||||
[(drag/above) (list #f #f #f)]
|
||||
[(drag-raise/above) (list #f #f #t)]
|
||||
[(drag/below) (list #f #t #f)]
|
||||
[(drag-raise/below) (list #f #t #t)]
|
||||
[else (error 'set-button-action "unknown action: ~s" action)])])
|
||||
(set! button-map
|
||||
(cons
|
||||
(cons button map)
|
||||
(remq (assoc button button-map)
|
||||
button-map)))))])
|
||||
(super-make-object)
|
||||
(set-selection-visible #f)))
|
||||
|
||||
(define table%
|
||||
(class mred:frame%
|
||||
(init title w h)
|
||||
(inherit reflow-container)
|
||||
(augment*
|
||||
[on-close
|
||||
(lambda ()
|
||||
(exit))])
|
||||
(public*
|
||||
[table-width (lambda ()
|
||||
(reflow-container)
|
||||
(let-values ([(x y w h) (send pb get-full-box)])
|
||||
w))]
|
||||
[table-height (lambda ()
|
||||
(reflow-container)
|
||||
(let-values ([(x y w h) (send pb get-full-box)])
|
||||
h))]
|
||||
[begin-card-sequence
|
||||
(lambda ()
|
||||
(set! in-sequence (add1 in-sequence))
|
||||
(send pb begin-edit-sequence))]
|
||||
[end-card-sequence
|
||||
(lambda ()
|
||||
(send pb end-edit-sequence)
|
||||
(set! in-sequence (sub1 in-sequence)))]
|
||||
[add-card
|
||||
(lambda (card x y)
|
||||
(position-cards (list card) x y (lambda (p) (values 0 0)) add-cards-callback))]
|
||||
[add-cards
|
||||
(lambda (cards x y [offset (lambda (p) (values 0 0))])
|
||||
(position-cards cards x y offset add-cards-callback))]
|
||||
[add-cards-to-region
|
||||
(lambda (cards region)
|
||||
(position-cards-in-region cards region add-cards-callback))]
|
||||
[move-card
|
||||
(lambda (card x y)
|
||||
(position-cards (list card) x y (lambda (p) (values 0 0)) move-cards-callback))]
|
||||
[move-cards
|
||||
(lambda (cards x y [offset (lambda (p) (values 0 0))])
|
||||
(position-cards cards x y offset move-cards-callback))]
|
||||
[move-cards-to-region
|
||||
(lambda (cards region)
|
||||
(position-cards-in-region cards region (lambda (c x y) (send pb move-to c x y))))]
|
||||
[card-location
|
||||
(lambda (card)
|
||||
(let ([x (box 0)]
|
||||
[y (box 0)])
|
||||
(unless (send pb get-snip-location card x y)
|
||||
(raise-mismatch-error 'card-location "card not on table: " card))
|
||||
(values (unbox x) (unbox y))))]
|
||||
[all-cards
|
||||
(lambda ()
|
||||
(send pb get-all-list))]
|
||||
[remove-card
|
||||
(lambda (card)
|
||||
(remove-cards (list card)))]
|
||||
[remove-cards
|
||||
(lambda (cards)
|
||||
(begin-card-sequence)
|
||||
(for-each (lambda (c) (send pb release-snip c)) cards)
|
||||
(end-card-sequence))]
|
||||
[flip-card
|
||||
(lambda (card)
|
||||
(flip-cards (list card)))]
|
||||
[flip-cards
|
||||
(lambda (cards)
|
||||
(if (or (not animate?) (positive? in-sequence))
|
||||
(for-each (lambda (c) (send c flip)) cards)
|
||||
(let ([flip-step
|
||||
(lambda (go)
|
||||
(let ([start (current-milliseconds)])
|
||||
(begin-card-sequence)
|
||||
(go)
|
||||
(end-card-sequence)
|
||||
(pause (max 0 (- (/ ANIMATION-TIME ANIMATION-STEPS)
|
||||
(/ (- (current-milliseconds) start) 1000))))))])
|
||||
(flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards)))
|
||||
(flip-step (lambda () (for-each (lambda (c) (send c flip)) cards)))
|
||||
(flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))]
|
||||
[rotate-card
|
||||
(lambda (card mode) (rotate-cards (list card) mode))]
|
||||
[rotate-cards
|
||||
(lambda (cards mode)
|
||||
(begin-card-sequence)
|
||||
(let ([tw (table-width)]
|
||||
[th (table-height)])
|
||||
(map (lambda (c)
|
||||
(let ([w (send c card-width)]
|
||||
[h (send c card-height)])
|
||||
(send c rotate mode)
|
||||
(let ([w2 (send c card-width)]
|
||||
[h2 (send c card-height)]
|
||||
[x (box 0)]
|
||||
[y (box 0)])
|
||||
(send pb get-snip-location c x y)
|
||||
(send pb move-to c
|
||||
(min (max 0 (+ (unbox x) (/ (- w w2) 2))) (- tw w2))
|
||||
(min (max 0 (+ (unbox y) (/ (- h h2) 2))) (- th h2))))))
|
||||
cards)
|
||||
(end-card-sequence)))]
|
||||
[card-face-up
|
||||
(lambda (card)
|
||||
(cards-face-up (list card)))]
|
||||
[cards-face-up
|
||||
(lambda (cards)
|
||||
(flip-cards (filter (lambda (c) (send c face-down?)) cards)))]
|
||||
[card-face-down
|
||||
(lambda (card)
|
||||
(cards-face-down (list card)))]
|
||||
[cards-face-down
|
||||
(lambda (cards)
|
||||
(flip-cards (filter (lambda (c) (not (send c face-down?))) cards)))]
|
||||
[card-to-front
|
||||
(lambda (card)
|
||||
(send pb set-before card #f))]
|
||||
[card-to-back
|
||||
(lambda (card)
|
||||
(send pb set-after card #f))]
|
||||
[stack-cards
|
||||
(lambda (cards)
|
||||
(unless (null? cards)
|
||||
(send pb only-front-selected) ; in case overlap changes
|
||||
(begin-card-sequence)
|
||||
(let loop ([l (cdr cards)][behind (car cards)])
|
||||
(unless (null? l)
|
||||
(send pb set-after (car l) behind)
|
||||
(loop (cdr l) (car l))))
|
||||
(end-card-sequence)))]
|
||||
[add-region
|
||||
(lambda (r)
|
||||
(send pb add-region r))]
|
||||
[remove-region
|
||||
(lambda (r)
|
||||
(send pb remove-region r))]
|
||||
[hilite-region
|
||||
(lambda (r)
|
||||
(send pb hilite-region r))]
|
||||
[unhilite-region
|
||||
(lambda (r)
|
||||
(send pb unhilite-region r))]
|
||||
[set-button-action
|
||||
(lambda (button action)
|
||||
(send pb set-button-action button action))]
|
||||
[set-double-click-action
|
||||
(lambda (a)
|
||||
(send pb set-double-click-action a))]
|
||||
[set-single-click-action
|
||||
(lambda (a)
|
||||
(send pb set-single-click-action a))]
|
||||
[pause
|
||||
(lambda (duration)
|
||||
(let ([s (make-semaphore)]
|
||||
[a (alarm-evt (+ (current-inexact-milliseconds)
|
||||
(* duration 1000)))]
|
||||
[enabled? (send c is-enabled?)])
|
||||
;; Can't move the cards during this time:
|
||||
(send c enable #f)
|
||||
(mred:yield a)
|
||||
(when enabled?
|
||||
(send c enable #t))))]
|
||||
[animated
|
||||
(case-lambda
|
||||
[() animate?]
|
||||
[(on?) (set! animate? (and on? #t))])]
|
||||
[create-status-pane
|
||||
(lambda ()
|
||||
(let ([p (make-object mred:horizontal-pane% this)])
|
||||
(set! msg (new mred:message%
|
||||
[parent p]
|
||||
[label ""]
|
||||
[stretchable-width #t]))
|
||||
p))]
|
||||
[set-status
|
||||
(lambda (str)
|
||||
(when msg
|
||||
(send msg set-label str)))]
|
||||
[add-help-button
|
||||
(lambda (pane where title tt?)
|
||||
(new mred:button%
|
||||
(parent pane)
|
||||
(label (string-constant help-menu-label))
|
||||
(callback
|
||||
(let ([show-help (show-help where title tt?)])
|
||||
(lambda x
|
||||
(show-help))))))]
|
||||
[add-scribble-button
|
||||
(lambda (pane mod tag)
|
||||
(new mred:button%
|
||||
(parent pane)
|
||||
(label (string-constant help-menu-label))
|
||||
(callback
|
||||
(let ([show-help (show-scribbling mod tag)])
|
||||
(lambda x
|
||||
(show-help))))))])
|
||||
(begin
|
||||
(define msg #f)
|
||||
(define add-cards-callback
|
||||
(lambda (card x y)
|
||||
(send pb insert card #f x y)))
|
||||
(define move-cards-callback
|
||||
(lambda (card x y)
|
||||
(send pb move-to card x y)
|
||||
(send card remember-location pb))))
|
||||
(begin
|
||||
(define animate? #t)
|
||||
(define in-sequence 0))
|
||||
(private*
|
||||
[position-cards
|
||||
(lambda (cards x y offset set)
|
||||
(let ([positions (let loop ([l cards][n 0])
|
||||
(if (null? l)
|
||||
null
|
||||
(let-values ([(dx dy) (offset n)])
|
||||
(cons (cons (+ x dx) (+ y dy))
|
||||
(loop (cdr l) (add1 n))))))])
|
||||
(if (or (not animate?) (positive? in-sequence) (eq? set add-cards-callback))
|
||||
(begin
|
||||
(begin-card-sequence)
|
||||
(for-each (lambda (c p) (set c (car p) (cdr p))) cards positions)
|
||||
(end-card-sequence))
|
||||
(let-values ([(moving-cards
|
||||
source-xs
|
||||
source-ys
|
||||
dest-xs
|
||||
dest-ys)
|
||||
(let loop ([cl cards][pl positions])
|
||||
(if (null? cl)
|
||||
(values null null null null null)
|
||||
(let-values ([(mcl sxl syl dxl dyl) (loop (cdr cl) (cdr pl))]
|
||||
[(card) (car cl)]
|
||||
[(x y) (values (caar pl) (cdar pl))])
|
||||
(let ([xb (box 0)][yb (box 0)])
|
||||
(send pb get-snip-location card xb yb)
|
||||
(let ([sx (unbox xb)][sy (unbox yb)])
|
||||
(if (and (= x sx) (= y sy))
|
||||
(values mcl sxl syl dxl dyl)
|
||||
(values (cons card mcl)
|
||||
(cons sx sxl)
|
||||
(cons sy syl)
|
||||
(cons x dxl)
|
||||
(cons y dyl))))))))])
|
||||
(let ([time-scale
|
||||
;; An animation speed that looks good for
|
||||
;; long moves looks too slow for short
|
||||
;; moves. So scale the time back by as much
|
||||
;; as 50% if the max distance for all cards
|
||||
;; is short.
|
||||
(let ([max-delta (max (apply max 0 (map (lambda (sx dx)
|
||||
(abs (- sx dx)))
|
||||
source-xs dest-xs))
|
||||
(apply max 0 (map (lambda (sy dy)
|
||||
(abs (- sy dy)))
|
||||
source-ys dest-ys)))])
|
||||
(if (max-delta . < . 100)
|
||||
(/ (+ max-delta 100) 200.0)
|
||||
1))])
|
||||
(let loop ([n 1])
|
||||
(unless (> n ANIMATION-STEPS)
|
||||
(let ([start (current-milliseconds)]
|
||||
[scale (lambda (s d)
|
||||
(+ s (* (/ n ANIMATION-STEPS) (- d s))))])
|
||||
(begin-card-sequence)
|
||||
(for-each
|
||||
(lambda (c sx sy dx dy)
|
||||
(set c (scale sx dx) (scale sy dy)))
|
||||
moving-cards
|
||||
source-xs source-ys
|
||||
dest-xs dest-ys)
|
||||
(end-card-sequence)
|
||||
(pause (max 0 (- (/ (* time-scale ANIMATION-TIME) ANIMATION-STEPS)
|
||||
(/ (- (current-milliseconds) start) 1000))))
|
||||
(loop (add1 n))))))))
|
||||
;; In case overlap changed:
|
||||
(send pb only-front-selected)))]
|
||||
[position-cards-in-region
|
||||
(lambda (cards r set)
|
||||
(unless (null? cards)
|
||||
(let-values ([(x y w h) (send pb get-region-box r)]
|
||||
[(len) (sub1 (length cards))]
|
||||
[(cw ch) (values (send (car cards) card-width)
|
||||
(send (car cards) card-height))])
|
||||
(let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
|
||||
[pw (pretty cw)]
|
||||
[ph (pretty ch)])
|
||||
(let-values ([(x w) (if (> w pw)
|
||||
(values (+ x (/ (- w pw) 2)) pw)
|
||||
(values x w))]
|
||||
[(y h) (if (> h ph)
|
||||
(values (+ y (/ (- h ph) 2)) ph)
|
||||
(values y h))])
|
||||
(position-cards cards x y
|
||||
(lambda (p)
|
||||
(if (zero? len)
|
||||
(values (/ (- w cw) 2)
|
||||
(/ (- h ch) 2))
|
||||
(values (* (- len p) (/ (- w cw) len))
|
||||
(* (- len p) (/ (- h ch) len)))))
|
||||
set))))))])
|
||||
(super-new [label title] [style '(metal no-resize-border)])
|
||||
(begin
|
||||
(define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll)))
|
||||
(define pb (make-object pasteboard%)))
|
||||
(send c min-client-width (+ 10 (inexact->exact (floor (* w (send back get-width))))))
|
||||
(send c min-client-height (+ 10 (inexact->exact (floor (* h (send back get-height))))))
|
||||
(send c stretchable-width #f)
|
||||
(send c stretchable-height #f)
|
||||
(send this stretchable-width #f)
|
||||
(send this stretchable-height #f)
|
||||
(send c set-editor pb)))
|
||||
|
||||
(define (draw-roundish-rectangle dc x y w h)
|
||||
(send dc draw-line (+ x 1) y (+ x w -2) y)
|
||||
(send dc draw-line (+ x 1) (+ y h -1) (+ x w -2) (+ y h -1))
|
||||
(send dc draw-line x (+ y 1) x (+ y h -2))
|
||||
(send dc draw-line (+ x w -1) (+ y 1) (+ x w -1) (+ y h -2))))
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
|
||||
(module constants racket
|
||||
(require racket/class
|
||||
racket/gui)
|
||||
|
||||
(provide ANIMATION-STEPS
|
||||
ANIMATION-TIME
|
||||
|
||||
PRETTY-CARD-SEP-AMOUNT
|
||||
|
||||
white-brush
|
||||
hilite-brush
|
||||
black-pen
|
||||
dark-gray-pen
|
||||
no-pen
|
||||
black-color
|
||||
nice-font)
|
||||
|
||||
(define ANIMATION-STEPS 5)
|
||||
(define ANIMATION-TIME 0.3)
|
||||
|
||||
(define PRETTY-CARD-SEP-AMOUNT 5)
|
||||
|
||||
(define black-color
|
||||
(make-object color% "black"))
|
||||
|
||||
(define white-brush
|
||||
(send the-brush-list
|
||||
find-or-create-brush
|
||||
"white" 'solid))
|
||||
|
||||
(define hilite-brush
|
||||
(send the-brush-list
|
||||
find-or-create-brush
|
||||
black-color 'hilite))
|
||||
|
||||
(define black-pen
|
||||
(send the-pen-list
|
||||
find-or-create-pen
|
||||
black-color 1 'solid))
|
||||
|
||||
(define dark-gray-pen
|
||||
(send the-pen-list
|
||||
find-or-create-pen
|
||||
"dark gray" 1 'solid))
|
||||
|
||||
(define no-pen
|
||||
(send the-pen-list
|
||||
find-or-create-pen
|
||||
black-color 1 'transparent))
|
||||
|
||||
(define nice-font
|
||||
(send the-font-list
|
||||
find-or-create-font
|
||||
12 'decorative 'normal 'bold
|
||||
#f 'default #t)))
|
||||
|
||||
|
|
@ -1,301 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; Code used to generate card images, just in case the cards
|
||||
;; need to be regenarted in a similar way. This code relies
|
||||
;; on fonts that were available on a Mac OS X 10.9 machine
|
||||
;; at the time that the cards were generated.
|
||||
|
||||
(module generate racket
|
||||
(require racket/draw)
|
||||
|
||||
(define W 71)
|
||||
(define H 96)
|
||||
|
||||
(define IW 41)
|
||||
(define IH 73)
|
||||
|
||||
;; Numbers: Lucida Grande
|
||||
;; Letters: Helvetica
|
||||
;; Suits: Osaka
|
||||
|
||||
(define (extract-color)
|
||||
(define bm0 (read-bitmap "card-1-1.png"))
|
||||
(define c (new color%))
|
||||
(send (send bm0 make-dc) get-pixel (sub1 (sub1 W)) 20 c)
|
||||
(list
|
||||
(send c red)
|
||||
(send c green)
|
||||
(send c blue)))
|
||||
|
||||
;; Extract the core of a face card so that it can be re-decorated.
|
||||
;; some by-hand editing may be needed to generate images
|
||||
;; in "faces-clean". Create initial cards by scaling up the originals
|
||||
;; such as ImageMagick's `-adaptive-resize` mode.
|
||||
(define (extract-faces)
|
||||
(define D 0)
|
||||
(define dh 2)
|
||||
(define tw (* 2 (+ D IW)))
|
||||
(define th (- (* 2 (+ D IH)) (* 2 dh)))
|
||||
(define T 200)
|
||||
|
||||
(for* ([val (in-range 10 13)]
|
||||
[suit 4])
|
||||
|
||||
(define (white-out bstr x y)
|
||||
(define Zx (cond
|
||||
[(and (= val 11) (= suit 3)) 26]
|
||||
[(and (= val 12) (= suit 0)) 28]
|
||||
[(and (= val 12) (= suit 2)) 28]
|
||||
[else 32]))
|
||||
(define Zy 40)
|
||||
(when (or (and (< 0 x Zx) (< 0 y Zy))
|
||||
(and (< (- tw Zx) x tw) (< (- th Zy) y th)))
|
||||
(define p (* 4 (+ x (* y tw))))
|
||||
(define r (bytes-ref bstr (+ p 1)))
|
||||
(define g (bytes-ref bstr (+ p 2)))
|
||||
(define b (bytes-ref bstr (+ p 3)))
|
||||
(unless (and (r . > . T)
|
||||
(g . > . T)
|
||||
(b . > . T))
|
||||
(bytes-set! bstr (+ p 1) 255)
|
||||
(bytes-set! bstr (+ p 2) 255)
|
||||
(bytes-set! bstr (+ p 3) 255)
|
||||
(white-out bstr (- x 1) y)
|
||||
(white-out bstr (+ x 1) y)
|
||||
(white-out bstr x (- y 1))
|
||||
(white-out bstr x (+ y 1)))))
|
||||
|
||||
(define old-bm (read-bitmap
|
||||
(collection-file-path (format "card-~a-~a@2x.png" val suit) "games/cards/hicolor")))
|
||||
(define bm2 (make-bitmap tw th))
|
||||
(define dc (send bm2 make-dc))
|
||||
(define dx (quotient (- W (+ D IW)) 2))
|
||||
(define dy (quotient (- H (+ D IH)) 2))
|
||||
(send dc draw-bitmap-section old-bm 0 0 (* 2 dx) (+ (* 2 dy) dh) tw th)
|
||||
(define bstr (make-bytes (* tw th 4)))
|
||||
(send bm2 get-argb-pixels 0 0 tw th bstr)
|
||||
(define P 16)
|
||||
(white-out bstr P P)
|
||||
(white-out bstr (- tw P) (- th P))
|
||||
(send bm2 set-argb-pixels 0 0 tw th bstr)
|
||||
(send bm2 save-file (format "faces/face-~a-~a.png" val suit) 'png)))
|
||||
|
||||
(define (card suit val)
|
||||
(define bm (make-bitmap W H #:backing-scale 2))
|
||||
(define dc (send bm make-dc))
|
||||
|
||||
(define clip-path (new dc-path%))
|
||||
(define R 4)
|
||||
(send clip-path move-to R 0)
|
||||
(send clip-path arc (- W R) 0 R R (* pi 1/2) 0 #f)
|
||||
(send clip-path arc (- W R) (- H R) R R 0 (* pi -1/2) #f)
|
||||
(send clip-path arc 0 (- H R) R R (* pi -1/2) (* pi -1) #f)
|
||||
(send clip-path arc 0 0 R R (* pi -1) (* pi -3/2) #f)
|
||||
(send clip-path close)
|
||||
(define region (new region%))
|
||||
(send region set-path clip-path)
|
||||
(send dc set-clipping-region region)
|
||||
|
||||
(send dc set-pen "black" 1 'transparent)
|
||||
(send dc set-brush (make-color 236 236 186) 'solid)
|
||||
(send dc draw-rectangle 0 0 W H)
|
||||
|
||||
(send dc set-smoothing 'smoothed)
|
||||
(send dc set-brush "black" 'transparent)
|
||||
(define tr (send dc get-transformation))
|
||||
(send dc translate -1.0 -1.0)
|
||||
(send dc set-pen (make-color 200 200 180) 2 'solid)
|
||||
(send dc draw-path clip-path 0 0)
|
||||
(send dc set-transformation tr)
|
||||
(send dc set-pen (make-color 150 150 100) 2 'solid)
|
||||
(send dc draw-path clip-path 0 0)
|
||||
(send dc set-smoothing 'aligned)
|
||||
|
||||
(cond
|
||||
[(and (not suit) (not val))
|
||||
(define dx 4)
|
||||
(send dc set-pen "black" 1 'transparent)
|
||||
(send dc set-brush (make-color 0 170 0) 'solid)
|
||||
(send dc draw-rectangle dx dx (- W dx dx) (- H dx dx))
|
||||
(send dc set-clipping-rect dx dx (- W dx dx) (- H dx dx))
|
||||
(send dc set-text-foreground (make-color 0 240 0))
|
||||
(send dc set-font (make-font #:face "Athelas" #:size 16))
|
||||
(define-values (lw lh ld la) (send dc get-text-extent "\u3BB"))
|
||||
(define d (/ (- W dx dx) 8))
|
||||
(for* ([j (in-range -4 5)]
|
||||
[i (in-range 8)])
|
||||
(define x (+ dx (* i d)))
|
||||
(define y (+ -2 (/ W 2) (* j (+ 1 (/ (- H dx dx) 8)))))
|
||||
(define flip? (odd? (+ i j)))
|
||||
(send dc draw-text "\u3BB"
|
||||
(+ x (if flip? 0 lw))
|
||||
(+ y (if flip? 0 lh))
|
||||
#f 0 (if flip? 0 pi)))]
|
||||
[else
|
||||
(define pip
|
||||
(case suit
|
||||
[(0) "\u2663"] ; club
|
||||
[(1) "\u2666"] ; diamond
|
||||
[(2) "\u2665"] ; heart
|
||||
[(3) "\u2660"])) ; spade
|
||||
(define color
|
||||
(case suit
|
||||
[(0 3) "black"]
|
||||
[(1 2) (make-color 240 0 0)]))
|
||||
(define num
|
||||
(case val
|
||||
[(0) "A"]
|
||||
[(9) "I0"]
|
||||
[(10) "J"]
|
||||
[(11) "Q"]
|
||||
[(12) "K"]
|
||||
[else (format "~a" (add1 val))]))
|
||||
(define squish
|
||||
(case val
|
||||
[(9) #e0.9]
|
||||
[(10) #e1.1]
|
||||
[(11) #e0.8]
|
||||
[else 1]))
|
||||
|
||||
(send dc set-text-foreground color)
|
||||
|
||||
(when (val . > . 9)
|
||||
(define (get)
|
||||
(read-bitmap (format "faces-clean/face-~a-~a.png" val suit)))
|
||||
(define old-bm (get))
|
||||
(define old-bm2 (get))
|
||||
|
||||
(define odc (send old-bm make-dc))
|
||||
(send odc rotate pi)
|
||||
(send odc translate (- (send old-bm get-width)) (- (send old-bm get-height)))
|
||||
(send odc set-clipping-rect 0 0 (send old-bm get-width) (quotient (send old-bm get-height) 2))
|
||||
(send odc draw-bitmap old-bm2 0 0)
|
||||
|
||||
(define tr (send dc get-transformation))
|
||||
(send dc scale 0.5 0.5)
|
||||
(define D 0)
|
||||
(define dh 2)
|
||||
(define dx (quotient (- W (+ D IW)) 2))
|
||||
(define dy (quotient (- H (+ D IH)) 2))
|
||||
(send dc draw-bitmap old-bm (* 2 dx) (+ (* 2 dy) dh))
|
||||
(send dc set-transformation tr)
|
||||
(send dc set-pen (make-color 150 150 100) 1 'solid)
|
||||
(send dc draw-rectangle (- dx 1) (- dy 0) (+ IW 2) (+ IH 0)))
|
||||
|
||||
(define number? (<= 1 val 8))
|
||||
|
||||
(define (half first?)
|
||||
(send dc set-font (make-font #:face (if number?
|
||||
"Lucida Grande"
|
||||
"Helvetica")
|
||||
#:weight 'bold #:size 18))
|
||||
|
||||
(define tr (send dc get-transformation))
|
||||
(send dc scale squish 1)
|
||||
(send dc draw-text num (/ 1 squish) (if number? 0 4) #t)
|
||||
(define-values (nw nh nd na) (send dc get-text-extent num))
|
||||
(send dc set-transformation tr)
|
||||
|
||||
(send dc set-font (make-font #:face "Osaka" #:size 12))
|
||||
(define-values (spw sph spd spa) (send dc get-text-extent pip))
|
||||
(send dc draw-text pip (+ 1 (quotient (- (floor (* squish nw)) spw) 2)) 20)
|
||||
|
||||
(send dc set-font (make-font #:face "Osaka" #:size 16))
|
||||
(define-values (pw ph pd pa) (send dc get-text-extent pip))
|
||||
|
||||
(define dx (quotient (- W IW) 2))
|
||||
(define dy (quotient (- H IH) 2))
|
||||
(define dy2 (+ dy ph (/ (- (/ IH 2) ph ph) 2)))
|
||||
|
||||
(define (pips n)
|
||||
(case n
|
||||
[(1)
|
||||
(when first?
|
||||
(cond
|
||||
[(and (= val 0) (= suit 3))
|
||||
(define S 6)
|
||||
|
||||
(define plt (read-bitmap (collection-file-path "PLT-206.png" "icons")))
|
||||
(define w (send plt get-width))
|
||||
(define h (send plt get-height))
|
||||
|
||||
(define spade (make-bitmap w h))
|
||||
(define sdc (send spade make-dc))
|
||||
(define f (make-font #:face (send (send dc get-font) get-face) #:size (* 4 64)))
|
||||
(define-values (pw ph pd pa) (send sdc get-text-extent pip f))
|
||||
(send sdc set-font f)
|
||||
(send sdc draw-text pip (quotient (- w pw) 2) (quotient (- h ph) 2))
|
||||
|
||||
(define bstr (make-bytes (* w h 4)))
|
||||
(send plt get-argb-pixels 0 0 w h bstr)
|
||||
(define sbstr (make-bytes (* w h 4)))
|
||||
(send spade get-argb-pixels 0 0 w h sbstr)
|
||||
|
||||
(for ([i (in-range 0 (* w h 4) 4)])
|
||||
(define a (quotient (+ (bytes-ref bstr (+ i 1))
|
||||
(bytes-ref bstr (+ i 2))
|
||||
(bytes-ref bstr (+ i 3)))
|
||||
3))
|
||||
(bytes-set! bstr i (bytes-ref sbstr i))
|
||||
(bytes-set! bstr (+ i 1) a)
|
||||
(bytes-set! bstr (+ i 2) a)
|
||||
(bytes-set! bstr (+ i 3) a))
|
||||
(send plt set-argb-pixels 0 0 w h bstr)
|
||||
(define tr (send dc get-transformation))
|
||||
(send dc scale (/ 1 S) (/ 1 S))
|
||||
(send dc draw-bitmap plt
|
||||
(* S (/ (- W (quotient w S)) 2))
|
||||
(* S (/ (- H (quotient h S)) 2)))
|
||||
(send dc set-transformation tr)]
|
||||
[else
|
||||
(send dc draw-text pip (quotient (- W pw) 2) (quotient (- H ph) 2))]))]
|
||||
[(2)
|
||||
(send dc draw-text pip (+ dx (quotient (- IW pw) 2)) dy)]
|
||||
[(3)
|
||||
(pips 1)
|
||||
(pips 2)]
|
||||
[(4)
|
||||
(send dc draw-text pip dx dy)
|
||||
(send dc draw-text pip (- W dx pw) dy)]
|
||||
[(5)
|
||||
(pips 4)
|
||||
(pips 1)]
|
||||
[(6)
|
||||
(pips 4)
|
||||
(when first?
|
||||
(send dc draw-text pip dx (quotient (- H ph) 2))
|
||||
(send dc draw-text pip (- W dx pw) (quotient (- H ph) 2)))]
|
||||
[(7)
|
||||
(pips 6)
|
||||
(when first?
|
||||
(send dc draw-text pip (quotient (- W pw) 2) (+ dy (- (quotient IH 3) (quotient ph 2)))))]
|
||||
[(8)
|
||||
(pips 4)
|
||||
(send dc draw-text pip dx dy2)
|
||||
(send dc draw-text pip (- W dx pw) dy2)]
|
||||
[(9)
|
||||
(pips 8)
|
||||
(pips 1)]
|
||||
[(10)
|
||||
(pips 8)
|
||||
(send dc draw-text pip (quotient (- W pw) 2) (+ dy (- (quotient IH 4) (quotient ph 2))))]
|
||||
[else
|
||||
(send dc set-brush "white" 'solid)
|
||||
(send dc set-pen "black" 1 'transparent)
|
||||
(send dc draw-rectangle dx (+ dy 2) (- pw 2) (+ ph 3))
|
||||
(send dc draw-text pip (- dx 1) (+ dy 2))]))
|
||||
|
||||
(pips (add1 val)))
|
||||
|
||||
(half #t)
|
||||
(send dc rotate pi)
|
||||
(send dc translate (- W) (- H))
|
||||
(half #f)])
|
||||
|
||||
bm)
|
||||
|
||||
(for* ([s 4]
|
||||
[n 13])
|
||||
(send (card s n) save-file (format "/tmp/cards/card-~a-~a@2x.png" n s) 'png #:unscaled? #t))
|
||||
|
||||
(send (card #f #f) save-file "/tmp/cards/card-back@2x.png" 'png #:unscaled? #t))
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 1.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 6.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.2 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.1 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 15 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 14 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 14 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 13 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 16 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 16 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 15 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 16 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 14 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.8 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 14 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 3.8 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 13 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.2 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 14 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.2 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.1 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.1 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.8 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.1 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.8 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.7 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.8 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.4 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.1 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 4.9 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.5 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 6.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1.8 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.3 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 2.0 KiB |
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user