got rid of loa, since I can no longer remember what it was and it does not run
svn: r18486
This commit is contained in:
Robby Findler
parent
afa3790620
commit
99638b8853
|
|
@ -1,296 +0,0 @@
|
|||
(unit/sig loa:grid^
|
||||
(import mzlib:function^
|
||||
mred^
|
||||
loa:utils^)
|
||||
|
||||
(define black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
|
||||
(define black-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))
|
||||
|
||||
(define highlight-color "PALE GREEN")
|
||||
(define highlight-pen (send the-pen-list find-or-create-pen highlight-color 1 'solid))
|
||||
(define highlight-brush (send the-brush-list find-or-create-brush highlight-color 'solid))
|
||||
|
||||
(define line-color "CORNFLOWER BLUE")
|
||||
(define line-pen (send the-pen-list find-or-create-pen line-color 1 'solid))
|
||||
(define line-brush (send the-brush-list find-or-create-brush line-color 'solid))
|
||||
|
||||
(define grid-pasteboard%
|
||||
(class pasteboard% (x-size y-size . args)
|
||||
(inherit get-canvas find-first-snip move-to invalidate-bitmap-cache)
|
||||
(private
|
||||
[calculate-grid
|
||||
(lambda (entries pixels)
|
||||
(build-vector
|
||||
(+ entries 1)
|
||||
(lambda (i) (* i (/ pixels entries)))))])
|
||||
|
||||
(private
|
||||
[margin 4]
|
||||
[pieces (build-vector x-size (lambda (i) (build-vector y-size (lambda (j) null))))]
|
||||
[y-grid (calculate-grid x-size (* x-size 2))]
|
||||
[x-grid (calculate-grid y-size (* y-size 2))])
|
||||
|
||||
(public
|
||||
[get-margin (lambda () margin)]
|
||||
[set-margin (lambda (m) (when (>= m 4) (set! margin m)))])
|
||||
|
||||
(public
|
||||
[get-moves
|
||||
(lambda (snip) (list (cons (send snip get-x) (send snip get-y))))])
|
||||
|
||||
(private
|
||||
[valid-move? (lambda (snip cx cy)
|
||||
(let ([legal-moves (get-moves snip)])
|
||||
(member
|
||||
(cons cx cy)
|
||||
legal-moves)))])
|
||||
|
||||
(private
|
||||
[grid-xy->pixel-xywh
|
||||
(lambda (x y)
|
||||
(let*-values ([(canvas) (get-canvas)]
|
||||
[(bx by) (send canvas get-client-size)])
|
||||
(values (* x (/ bx x-size))
|
||||
(* y (/ by y-size))
|
||||
(/ bx x-size)
|
||||
(/ by y-size))))]
|
||||
|
||||
|
||||
[pixel-xy->grid-xy
|
||||
(lambda (px py)
|
||||
(let*-values ([(canvas) (get-canvas)]
|
||||
[(bx by) (send canvas get-client-size)]
|
||||
[(gx) (floor (* x-size (/ px bx)))]
|
||||
[(gy) (floor (* y-size (/ py by)))])
|
||||
(values (inexact->exact gx) (inexact->exact gy))))])
|
||||
|
||||
(private
|
||||
[cursor-x/y #f]
|
||||
[update-cursor-x/y
|
||||
(lambda (new-x/y)
|
||||
(unless (equal? cursor-x/y new-x/y)
|
||||
(set! cursor-x/y new-x/y)
|
||||
(invalidate-bitmap-cache)))])
|
||||
|
||||
(rename [super-on-local-event on-local-event])
|
||||
(override
|
||||
[on-local-event
|
||||
(lambda (evt)
|
||||
(cond
|
||||
[(send evt leaving?)
|
||||
(update-cursor-x/y #f)]
|
||||
[(or (send evt moving?)
|
||||
(send evt entering?))
|
||||
(let-values ([(px py) (pixel-xy->grid-xy (send evt get-x) (send evt get-y))])
|
||||
(update-cursor-x/y (cons px py)))]
|
||||
[else (void)])
|
||||
(super-on-local-event evt))])
|
||||
|
||||
(private
|
||||
[ignored-move? #f])
|
||||
(public
|
||||
[animate-to
|
||||
(lambda (snip x y)
|
||||
(set! ignored-move? #t)
|
||||
(let* ([canvas (get-canvas)])
|
||||
(let-values ([(bx by) (send canvas get-client-size)])
|
||||
(move-to snip
|
||||
(* x (/ bx x-size))
|
||||
(* y (/ by y-size))))
|
||||
(set! ignored-move? #f)))])
|
||||
(inherit find-next-selected-snip)
|
||||
|
||||
(public
|
||||
[moved
|
||||
(lambda (l)
|
||||
(void))])
|
||||
|
||||
(override
|
||||
[after-interactive-move
|
||||
(lambda (event)
|
||||
(unless ignored-move?
|
||||
(let ([moved-snips
|
||||
(let-values ([(cx cy) (pixel-xy->grid-xy (send event get-x) (send event get-y))])
|
||||
(let loop ([snip (find-next-selected-snip #f)])
|
||||
(if snip
|
||||
(if (valid-move? snip cx cy)
|
||||
(begin (send snip set-x cx)
|
||||
(send snip set-y cy)
|
||||
(animate-to snip cx cy)
|
||||
(cons snip (loop (find-next-selected-snip snip))))
|
||||
(begin (bell)
|
||||
(animate-to snip (send snip get-x) (send snip get-y))
|
||||
(loop (find-next-selected-snip snip))))
|
||||
null)))])
|
||||
(unless (null? moved-snips)
|
||||
(moved moved-snips)))
|
||||
(invalidate-bitmap-cache)))])
|
||||
|
||||
(rename [super-on-paint on-paint])
|
||||
(inherit begin-edit-sequence end-edit-sequence)
|
||||
(override
|
||||
[on-paint
|
||||
(lambda (before dc left top right bottom dx dy draw-caret)
|
||||
(let ([orig-pen (send dc get-pen)]
|
||||
[orig-brush (send dc get-brush)])
|
||||
|
||||
(when cursor-x/y
|
||||
(if before
|
||||
(begin (send dc set-pen highlight-pen)
|
||||
(send dc set-brush highlight-brush))
|
||||
(begin (send dc set-pen line-pen)
|
||||
(send dc set-brush line-brush)))
|
||||
(let ([snip (get-snip-at (car cursor-x/y) (cdr cursor-x/y))])
|
||||
(when snip
|
||||
(let ([spots (get-moves snip)])
|
||||
(for-each (lambda (spot)
|
||||
(let-values ([(x y w h) (grid-xy->pixel-xywh (car spot) (cdr spot))])
|
||||
(if before
|
||||
(send dc draw-rectangle (+ x dx) (+ y dy) w h)
|
||||
(let-values ([(fx fy fw fh) (grid-xy->pixel-xywh (car cursor-x/y) (cdr cursor-x/y))])
|
||||
(send dc draw-line
|
||||
(+ fx (/ fw 2))
|
||||
(+ fy (/ fh 2))
|
||||
(+ x (/ w 2))
|
||||
(+ y (/ h 2)))))))
|
||||
spots)))))
|
||||
|
||||
(when before
|
||||
(send dc set-pen black-pen)
|
||||
|
||||
(vector-for-each
|
||||
(get-x-grid)
|
||||
(lambda (x)
|
||||
(send dc draw-line (+ x dx) (+ top dy) (+ x dx) (+ bottom dy))))
|
||||
|
||||
(vector-for-each
|
||||
(get-y-grid)
|
||||
(lambda (y)
|
||||
(send dc draw-line (+ left dx) (+ y dy) (+ right dx) (+ y dy)))))
|
||||
|
||||
(super-on-paint before dc left top right bottom dx dy draw-caret)
|
||||
|
||||
(send dc set-pen orig-pen)
|
||||
(send dc set-brush orig-brush)))])
|
||||
|
||||
(public
|
||||
[on-size
|
||||
(lambda (w h)
|
||||
(set! x-grid (calculate-grid x-size w))
|
||||
(set! y-grid (calculate-grid y-size h))
|
||||
(let ([xs (/ w x-size)]
|
||||
[ys (/ h y-size)])
|
||||
(begin-edit-sequence)
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(cond
|
||||
[(not snip) (void)]
|
||||
[else
|
||||
(send snip allow-resize #t)
|
||||
(send snip resize xs ys)
|
||||
(send snip allow-resize #f)
|
||||
(move-to snip
|
||||
(* xs (send snip get-x))
|
||||
(* ys (send snip get-y)))
|
||||
(loop (send snip next))]))
|
||||
(end-edit-sequence)))])
|
||||
|
||||
(public
|
||||
[get-x-grid (lambda () x-grid)]
|
||||
[get-y-grid (lambda () y-grid)]
|
||||
[get-pieces (lambda () pieces)])
|
||||
|
||||
(inherit insert resize find-snip)
|
||||
(public
|
||||
[get-snip-at
|
||||
(lambda (x y)
|
||||
(let ([snips (get-all-snips-at x y)])
|
||||
(if (null? snips)
|
||||
#f
|
||||
(car snips))))]
|
||||
|
||||
[get-all-snips-at
|
||||
(lambda (x y)
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(cond
|
||||
[snip
|
||||
(if (and (= x (send snip get-x))
|
||||
(= y (send snip get-y)))
|
||||
(cons snip (loop (send snip next)))
|
||||
(loop (send snip next)))]
|
||||
[else null])))]
|
||||
|
||||
[insert-at
|
||||
(lambda (snip x y)
|
||||
(send snip set-x x)
|
||||
(send snip set-y y)
|
||||
(let ([canvas (get-canvas)])
|
||||
(if canvas
|
||||
(let-values ([(bx by) (send canvas get-client-size)])
|
||||
(let* ([xw (/ bx x-size)]
|
||||
[yw (/ by y-size)]
|
||||
[cx (* x xw)]
|
||||
[cy (* y yw)])
|
||||
(insert snip cx cy)
|
||||
(resize snip xw yw)))
|
||||
(insert snip 0 0)))
|
||||
(let ([col (vector-ref pieces x)])
|
||||
(vector-set! col y (cons snip (vector-ref col y)))))])
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
(define grid-canvas%
|
||||
(class editor-canvas% args
|
||||
(inherit get-editor)
|
||||
(rename [super-get-client-size get-client-size])
|
||||
(override
|
||||
[get-client-size
|
||||
(lambda ()
|
||||
(let-values ([(w h) (super-get-client-size)])
|
||||
(values (max 0 (- w 11))
|
||||
(max 0 (- h 11)))))]
|
||||
[on-size
|
||||
(lambda (width height)
|
||||
(let ([media (get-editor)])
|
||||
(when media
|
||||
(let-values ([(w h) (get-client-size)])
|
||||
(send media on-size w h)))))])
|
||||
(sequence (apply super-init args))))
|
||||
|
||||
(define grid-snip%
|
||||
(class snip% (_x _y)
|
||||
(private
|
||||
[width 10]
|
||||
[height 10])
|
||||
(public
|
||||
[allow-resize
|
||||
(let ([ans #f])
|
||||
(case-lambda
|
||||
[(x) (set! ans x)]
|
||||
[() ans]))]
|
||||
[get-width (lambda () width)]
|
||||
[get-height (lambda () height)])
|
||||
(inherit get-admin)
|
||||
(override
|
||||
[resize
|
||||
(lambda (w h)
|
||||
(and (allow-resize)
|
||||
(begin (set! width w)
|
||||
(set! height h)
|
||||
(send (get-admin) resized this #f)
|
||||
#t)))]
|
||||
[get-extent
|
||||
(lambda (dc x y w h descent space lspace rspace)
|
||||
(for-each (lambda (b) (when (box? b) (set-box! b 0)))
|
||||
(list descent space lspace rspace))
|
||||
(when (box? w) (set-box! w width))
|
||||
(when (box? h) (set-box! h height)))])
|
||||
|
||||
(private
|
||||
[x _x]
|
||||
[y _y])
|
||||
(public
|
||||
[get-x (lambda () x)]
|
||||
[get-y (lambda () y)]
|
||||
[set-x (lambda (nx) (set! x nx))]
|
||||
[set-y (lambda (ny) (set! y ny))])
|
||||
(sequence (super-init)))))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define compile-omit-paths 'all)
|
||||
|
|
@ -1,158 +0,0 @@
|
|||
(require-library "pretty.ss")
|
||||
|
||||
(unit/sig loa^
|
||||
(import mzlib:function^
|
||||
mred^
|
||||
loa:computer-player^
|
||||
loa:grid^)
|
||||
|
||||
(define color "VIOLET RED")
|
||||
|
||||
(define black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
|
||||
(define black-brush (send the-brush-list find-or-create-brush "BLACK" 'solid))
|
||||
(define white-pen (send the-pen-list find-or-create-pen color 1 'solid))
|
||||
(define white-brush (send the-brush-list find-or-create-brush color 'solid))
|
||||
|
||||
(define loa-canvas% grid-canvas%)
|
||||
|
||||
(define (get-connected-region board snip)
|
||||
(let ([ht (make-hash-table)])
|
||||
(let loop ([snip snip])
|
||||
(hash-table-get
|
||||
ht
|
||||
snip
|
||||
(lambda ()
|
||||
(hash-table-put! ht snip #t)
|
||||
(let* ([x (send snip get-x)]
|
||||
[y (send snip get-y)]
|
||||
[check
|
||||
(lambda (nx ny)
|
||||
(let* ([next-snip (send board get-snip-at nx ny)]
|
||||
[condition
|
||||
(and next-snip
|
||||
(eq? (send next-snip get-color)
|
||||
(send snip get-color)))])
|
||||
(printf "at (~a, ~a) looking (~a, ~a): ~a~n" x y nx ny condition)
|
||||
(when condition
|
||||
(loop next-snip))))])
|
||||
(check (+ x 1) y)
|
||||
(check (- x 1) y)
|
||||
(check x (+ y 1))
|
||||
(check x (- y 1))
|
||||
(check (+ x 1) (+ y 1))
|
||||
(check (- x 1) (+ y 1))
|
||||
(check (+ x 1) (- y 1))
|
||||
(check (- x 1) (- y 1))))))
|
||||
(hash-table-map ht (lambda (x y) x))))
|
||||
|
||||
(define (get-connected-regions board)
|
||||
(let loop ([regions null]
|
||||
[snip (send board find-first-snip)])
|
||||
(cond
|
||||
[(not snip) regions]
|
||||
[(ormap (lambda (region) (member snip region))
|
||||
regions)
|
||||
(loop regions
|
||||
(send snip next))]
|
||||
[else
|
||||
(loop (cons (get-connected-region board snip) regions)
|
||||
(send snip next))])))
|
||||
|
||||
(define loa-pasteboard%
|
||||
(class/d grid-pasteboard% (size)
|
||||
((inherit get-snip-at get-all-snips-at
|
||||
animate-to find-first-snip
|
||||
remove)
|
||||
(public get-size get-color-at
|
||||
(override get-moves moved))
|
||||
|
||||
(define (get-size) size)
|
||||
|
||||
(define (make-move snip x y)
|
||||
(send snip set-x x)
|
||||
(send snip set-y y)
|
||||
(animate-to snip x y))
|
||||
|
||||
(define (do-computer-move)
|
||||
(let-values ([(snip x y) (computer-move this)])
|
||||
(make-move snip x y)))
|
||||
|
||||
(define (moved moved-snips)
|
||||
(for-each (lambda (moved-snip)
|
||||
(for-each (lambda (overlapping-snip)
|
||||
(unless (eq? overlapping-snip moved-snip)
|
||||
(remove overlapping-snip)))
|
||||
(get-all-snips-at (send moved-snip get-x) (send moved-snip get-y))))
|
||||
moved-snips)
|
||||
(let ([semaphore (make-semaphore)])
|
||||
(thread
|
||||
(lambda ()
|
||||
(do-computer-move)
|
||||
(semaphore-post semaphore)))
|
||||
(yield semaphore)))
|
||||
|
||||
(define (get-color-at i j)
|
||||
(let loop ([snip (find-first-snip)])
|
||||
(cond
|
||||
[(not snip) #f]
|
||||
[else (if (and (= i (send snip get-x))
|
||||
(= j (send snip get-y)))
|
||||
(send snip get-color)
|
||||
(loop (send snip next)))])))
|
||||
|
||||
(define get-moves
|
||||
(let* ([get-color (lambda (board i j) (get-color-at i j))]
|
||||
[f
|
||||
(invoke-unit/sig (require-library "moves.ss" "games" "loa")
|
||||
loa:move-import^
|
||||
mzlib:function^)])
|
||||
(lambda (snip)
|
||||
(f (void) (send snip get-x) (send snip get-y)))))
|
||||
|
||||
(super-init size size)))
|
||||
|
||||
(define loa-checker%
|
||||
(class grid-snip% (color x y)
|
||||
|
||||
(inherit get-width get-height)
|
||||
(public
|
||||
[get-color
|
||||
(lambda () color)])
|
||||
(override
|
||||
[draw
|
||||
(lambda (dc x y left top right bottom dx dy draw-caret)
|
||||
(let ([width (get-width)]
|
||||
[height (get-height)])
|
||||
(if (eq? color 'black)
|
||||
(begin (send dc set-pen black-pen)
|
||||
(send dc set-brush black-brush))
|
||||
(begin (send dc set-pen white-pen)
|
||||
(send dc set-brush white-brush)))
|
||||
(send dc draw-ellipse x y width height)))])
|
||||
|
||||
(sequence
|
||||
(super-init x y))))
|
||||
|
||||
|
||||
(define frame (make-object frame% "Lines of Action" #f))
|
||||
(define loa-pasteboard (make-object loa-pasteboard% 8))
|
||||
(define loa-canvas (make-object loa-canvas% frame loa-pasteboard))
|
||||
|
||||
(send loa-canvas min-width 300)
|
||||
(send loa-canvas min-height 300)
|
||||
|
||||
(define (make color x y)
|
||||
(send loa-pasteboard insert
|
||||
(make-object loa-checker% color x y)))
|
||||
|
||||
(let loop ([n 6])
|
||||
(unless (zero? n)
|
||||
(make 'white 0 n)
|
||||
(make 'white 7 n)
|
||||
(make 'black n 0)
|
||||
(make 'black n 7)
|
||||
(loop (- n 1))))
|
||||
|
||||
(send frame show #t))
|
||||
|
||||
)
|
||||
|
|
@ -1 +0,0 @@
|
|||
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
#|
|
||||
|
||||
Matthew writes about the refreshing problem:
|
||||
|
||||
Quoting Robert Bruce Findler:
|
||||
> It appears that invalidate bitmap cache in a pasteboard invalidates the
|
||||
> smallest square of the pasteboard that contains all of the snips, which
|
||||
> might not be the entire visible region of the pasteboard. The
|
||||
> documentation (and my preferred behavior) would be that it invalidates
|
||||
> the entire visible region, not just the region with snips.
|
||||
|
||||
By default (i.e., unless `set-mininum-{width,height}' is called), the
|
||||
size of a pasetboard is the size of the smallest square that contains
|
||||
the pasteboard's snips. So both the documentation and implementation
|
||||
are correct in this case.
|
||||
|
||||
A pasteboard may be displayed in a canvas with extra space around the
|
||||
pasteboard's area. That area is indeed not invalidated by
|
||||
`invalidate-bitmap-cache'. Call `refresh' to foce the updating of a
|
||||
canvas.
|
||||
|
||||
I don't think `invalidate-bitmap-cache' should invalidate any area
|
||||
outside the editor's region; I belive the current behavior is the right
|
||||
one. I added a note on the difference to the docs.
|
||||
|
||||
|#
|
||||
|
||||
|
||||
(require-library "errortrace.ss" "errortrace")
|
||||
|
||||
(require-library "sig.ss" "games" "loa")
|
||||
|
||||
(invoke-unit/sig
|
||||
(compound-unit/sig
|
||||
(import (mred : mred^))
|
||||
(link
|
||||
[core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[utils : loa:utils^ ((require-library "utils.ss" "games" "loa"))]
|
||||
[grid : loa:grid^ ((require-library "grid.ss" "games" "loa") (core function) mred utils)]
|
||||
[computer : loa:computer-player^ ((require-library "computer.ss" "games" "loa") loa (core function))]
|
||||
[loa : loa^ ((require-library "loa.ss" "games" "loa") (core function) mred computer grid)])
|
||||
(export))
|
||||
mred^)
|
||||
|
||||
(yield (make-semaphore))
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
(require-library "cores.ss")
|
||||
(require-library "classd.ss")
|
||||
|
||||
(define-signature loa:grid^
|
||||
(grid-pasteboard%
|
||||
grid-canvas%
|
||||
grid-snip%))
|
||||
|
||||
(define-signature loa^
|
||||
(loa-pasteboard%
|
||||
loa-canvas%
|
||||
loa-checker%
|
||||
|
||||
get-connected-regions))
|
||||
|
||||
(define-signature loa:utils^
|
||||
(vector-for-each))
|
||||
|
||||
(define-signature loa:computer-player^
|
||||
(computer-move))
|
||||
|
||||
(define-signature loa:move-import^
|
||||
(get-color ; : (board num num -> (union 'black 'white #f))
|
||||
))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
(unit/sig loa:utils^
|
||||
(import)
|
||||
|
||||
(define (vector-for-each v f)
|
||||
(let loop ([n (vector-length v)])
|
||||
(unless (zero? n)
|
||||
(f (vector-ref v (- n 1)))
|
||||
(loop (- n 1))))))
|
||||
Loading…
Reference in New Issue
Block a user