From 99638b88534e602417157b3af8f17dd4017e28c6 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 8 Mar 2010 12:13:41 +0000
Subject: [PATCH] got rid of loa, since I can no longer remember what it was
 and it does not run

svn: r18486
---
 collects/games/loa/grid.ss  | 296 ------------------------------------
 collects/games/loa/info.ss  |   3 -
 collects/games/loa/loa.ss   | 158 -------------------
 collects/games/loa/main.ss  |   1 -
 collects/games/loa/run.ss   |  45 ------
 collects/games/loa/sig.ss   |  24 ---
 collects/games/loa/utils.ss |   8 -
 7 files changed, 535 deletions(-)
 delete mode 100644 collects/games/loa/grid.ss
 delete mode 100644 collects/games/loa/info.ss
 delete mode 100644 collects/games/loa/loa.ss
 delete mode 100644 collects/games/loa/main.ss
 delete mode 100644 collects/games/loa/run.ss
 delete mode 100644 collects/games/loa/sig.ss
 delete mode 100644 collects/games/loa/utils.ss

diff --git a/collects/games/loa/grid.ss b/collects/games/loa/grid.ss
deleted file mode 100644
index 0f88986f64..0000000000
--- a/collects/games/loa/grid.ss
+++ /dev/null
@@ -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)))))
diff --git a/collects/games/loa/info.ss b/collects/games/loa/info.ss
deleted file mode 100644
index a073420a94..0000000000
--- a/collects/games/loa/info.ss
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang setup/infotab
-
-(define compile-omit-paths 'all)
diff --git a/collects/games/loa/loa.ss b/collects/games/loa/loa.ss
deleted file mode 100644
index 9085afb1e0..0000000000
--- a/collects/games/loa/loa.ss
+++ /dev/null
@@ -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))
-
-)
diff --git a/collects/games/loa/main.ss b/collects/games/loa/main.ss
deleted file mode 100644
index 8b13789179..0000000000
--- a/collects/games/loa/main.ss
+++ /dev/null
@@ -1 +0,0 @@
-
diff --git a/collects/games/loa/run.ss b/collects/games/loa/run.ss
deleted file mode 100644
index 11327960ad..0000000000
--- a/collects/games/loa/run.ss
+++ /dev/null
@@ -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))
diff --git a/collects/games/loa/sig.ss b/collects/games/loa/sig.ss
deleted file mode 100644
index e50c6c365e..0000000000
--- a/collects/games/loa/sig.ss
+++ /dev/null
@@ -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))
-   ))
diff --git a/collects/games/loa/utils.ss b/collects/games/loa/utils.ss
deleted file mode 100644
index 11fdaba11a..0000000000
--- a/collects/games/loa/utils.ss
+++ /dev/null
@@ -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))))))