suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cleaned up old code so it now at least compiles (and, in some cases, runs)

Browse Source 
svn: r16331
This commit is contained in:
Robby Findler 2009-10-15 21:08:15 +00:00
parent c40c3a9884
commit 8bd7de80e3
12 changed files with 111 additions and 3412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/games/paint-by-numbers/info.ss
View File

@ -3,23 +3,7 @@
(define game "paint-by-numbers.ss")
(define game-set "Puzzle Games")
(define compile-omit-paths
'(;; Skipped because it's huge - lots of data-encoding units
"all-problems.ss"
;; Skipped because it requires all-problems.ss
"paint-by-numbers.ss"
;; Skipped because these are used only to build the huge units.
"build-hattori.ss"
"build-kajitani.ss"
"build-problems.ss"
"raw-hattori.ss"
"raw-kajitani.ss"
"raw-problems.ss"
"raw-misc.ss"
"build-rows-cols.ss"
"count-missing.ss"
"main.ss"
;; directories too
'("main.ss"
"hattori"
"problems"
"raw-problems"
"solution-sets"))

10
collects/games/paint-by-numbers/raw-problems/build-final.ss
View File

@ -1,6 +1,6 @@
#!/bin/sh
#lang mzscheme
#|
exec mzscheme -qr $0 "$@"
This script constructs the contents of the problems directory
from the solutions directory. This process merely consists of
@ -30,7 +30,7 @@ in ...
(define set-name ,set-name)
(define problems (list ,@problems)))
(define problems (list ,problems ...)))
`(unit/sig paint-by-numbers:problem-set^
(import paint-by-numbers:problem^)
@ -68,4 +68,6 @@ in ...
(copy-file (build-path 'up "solution-sets" "directory")
(build-path 'up "problems" "directory"))
(for-each shrink-file (call-with-input-file (build-path 'up "problems" "directory") read))
(provide main)
(define (main)
(for-each shrink-file (call-with-input-file (build-path 'up "problems" "directory") read)))

34
collects/games/paint-by-numbers/raw-problems/build-hattori.ss
View File

@ -1,18 +1,13 @@
#!/bin/sh
string=? ; exec mred -qmvr $0
#lang scheme/gui
;;; these come from:
;;; http://www.ask.ne.jp/~hattori/puzzle/menu.html
;;; We must cite him in the game somewhere...
(require-library "pretty.ss")
(require-library "errortrace.ss" "errortrace")
(define pixel-size 10)
(define (main n)
(let ([grid (calculate-grid (build-path "hattori" (format "~a.gif" n)))])
(define (main-n n)
(let ([grid (calculate-grid (build-path 'up "hattori" (format "~a.gif" n)))])
(display-grid grid)
(pretty-print
(build-problem
@ -162,14 +157,15 @@ string=? ; exec mred -qmvr $0
(map on-off->blocks (transpose on-off-lists))
on-off-lists))
(call-with-output-file "raw-hattori.ss"
(lambda (port)
(parameterize ([current-output-port port])
(printf "`(~n")
(let loop ([n 1])
(when (<= n 139)
(main n)
(loop (+ n 1))))
(printf ")")))
'text
'truncate)
(provide main)
(define (main)
(call-with-output-file "raw-hattori.ss"
(lambda (port)
(parameterize ([current-output-port port])
(printf "`(~n")
(let loop ([n 1])
(when (<= n 139)
(main-n n)
(loop (+ n 1))))
(printf ")")))
#:exists 'truncate))

36
collects/games/paint-by-numbers/raw-problems/build-kajitani.ss
View File

@ -1,3 +1,7 @@
#lang scheme
;; AFAICT, the input to the thing is long gone.
#!/bin/sh
string=? ; exec mzscheme -qr $0
@ -5,11 +9,6 @@ string=? ; exec mzscheme -qr $0
;; this builds raw-kajitani.ss from full-kajitani
;; raw-kajitani.ss is used in build-problems.ss
(require-library "pretty.ss")
(require-library "function.ss")
(require-library "errortrace.ss" "errortrace")
(require-library "string.ss")
(define (make-strings-mutable sexp)
(cond
[(string? sexp) (string-copy sexp)]
@ -29,40 +28,41 @@ string=? ; exec mzscheme -qr $0
"allowed-email")
read)))
(define counters (make-hash-table))
(define counters (make-hasheq))
(define email-ht (make-hash-table))
(for-each (lambda (email) (hash-table-put! email-ht (string->symbol email) null))
(define email-ht (make-hasheq))
(for-each (lambda (email) (hash-set! email-ht (string->symbol email) null))
allowed-emails)
(define kajitani-sets
(let ([ht (make-hash-table)])
(let ([ht (make-hasheq)])
(for-each
(lambda (kaj-set)
(let ([email (cadddr kaj-set)])
(when (string? email)
(string-lowercase! email))
(let* ([raw-email (cadddr kaj-set)]
[email (if (string? raw-email)
(string-downcase raw-email)
raw-email)])
(when (member email allowed-emails)
(let ([email-sym (string->symbol email)])
(hash-table-put! email-ht email-sym
(hash-set! email-ht email-sym
(cons
(car kaj-set)
(hash-table-get email-ht email-sym))))
(hash-ref email-ht email-sym))))
(let ([tag (string->symbol (format "~ax~a" (car (car kaj-set)) (cadr (car kaj-set))))]
[rows/cols (list (caddr (car kaj-set)) (cdr kaj-set))])
(hash-table-put!
(hash-set!
ht
tag
(cons
rows/cols
(hash-table-get
(hash-ref
ht
tag
(lambda ()
null))))))))
raw-kajitani)
(hash-table-map ht (lambda (x l) (list x (reverse l))))))
(hash-map ht (lambda (x l) (list x (reverse l))))))
(printf "stats by email~n")
(let ([total 0])
@ -76,7 +76,7 @@ string=? ; exec mzscheme -qr $0
len
;v
))))
(sort (hash-table-map email-ht list)
(sort (hash-map email-ht list)
(lambda (x y) (> (length (cadr x)) (length (cadr y))))))

7
collects/games/paint-by-numbers/raw-problems/build-rows-cols.ss
View File

@ -1,6 +1,7 @@
#!/bin/sh
string=? ; exec mred -mvgqr $0 "$@"
#lang mzscheme
(require mred
mzlib/class)
(define argv (current-command-line-arguments))
(when (equal? (vector) argv)
(error 'build-rows-cols.ss

27
collects/games/paint-by-numbers/raw-problems/build-solution-sets.ss
View File

@ -1,6 +1,4 @@
#!/bin/sh
string=? ; exec mred -qr $0 "$@"
#lang mzscheme
#|
@ -24,9 +22,12 @@ The col and row type specs are in sig.ss and the solution type is:
mzlib/list
mzlib/file
mzlib/pretty
mzlib/class
mred
"raw-hattori.ss"
(prefix solve: "../solve.ss"))
(if (eq? (vector) argv)
(if (equal? (vector) argv)
(fprintf (current-error-port) "pass any command line argument to skip the solver~n~n")
(fprintf (current-error-port) "skipping the solver~n"))
@ -34,7 +35,7 @@ The col and row type specs are in sig.ss and the solution type is:
(define memory-frame%
(class frame%
(define/override (can-close?) #f)
(define/augment (can-close?) #f)
(super-instantiate ())))
(define memory-frame (parameterize ([current-eventspace (make-eventspace)])
@ -45,7 +46,7 @@ The col and row type specs are in sig.ss and the solution type is:
(define memory-ec (make-object editor-canvas% memory-vp memory-text '(hide-hscroll hide-vscroll)))
(define memory-gauge (make-object gauge% #f 10000 memory-vp))
(define memory-canvas (make-object canvas% memory-hp))
(define memory-on-bitmap (make-object bitmap% (build-path (collection-path "icons") "recycle.gif")))
(define memory-on-bitmap (make-object bitmap% (build-path (collection-path "icons") "recycle.png")))
(define memory-off-bitmap (make-object bitmap%
(send memory-on-bitmap get-width)
(send memory-on-bitmap get-height)))
@ -82,9 +83,6 @@ The col and row type specs are in sig.ss and the solution type is:
(define hattori-sets
(let* ([set-size 30]
[raw-hattori
(call-with-input-file (build-path problems-dir "raw-problems" "raw-hattori.ss")
(compose eval read))]
[hattori-count (length raw-hattori)])
(let o-loop ([n 0])
(cond
@ -111,13 +109,14 @@ The col and row type specs are in sig.ss and the solution type is:
output-file
(call-with-input-file (build-path problems-dir input-file) (compose eval read))))
(define games-set (build-set "Games Magazine" "games" "raw-problems/raw-problems.ss"))
(require "raw-problems.ss")
(define games-set (list "Games Magazine" "games" raw-problems))
(define misc-set (build-set "Misc" "misc" "raw-problems/raw-misc.ss"))
(require "raw-misc.ss")
(define misc-set (list "Misc" "misc" raw-misc))
(define kajitani-sets
(call-with-input-file (build-path (collection-path "games" "paint-by-numbers") "raw-problems" "raw-kajitani.ss")
read))
(require "raw-kajitani.ss")
(define kajitani-sets raw-kajitani)
(define sets (append (list games-set)
(list misc-set)

45
collects/games/paint-by-numbers/raw-problems/count-missing.ss
View File

@ -1,45 +0,0 @@
#!/bin/sh
string=? ; exec mzscheme -qr $0
(printf "checking problems in ~s~n" (collection-path "games" "paint-by-numbers"))
(require-library "sig.ss" "games" "paint-by-numbers")
(require-library "errortrace.ss" "errortrace")
(define counter
(unit/sig ()
(import paint-by-numbers:problem^
paint-by-numbers:all-problems^)
(define total 0)
(define total-missing 0)
(define (filter p l)
(cond
[(null? l) null]
[(p (car l)) (cons (car l) (filter p (cdr l)))]
[else (filter p (cdr l))]))
(define (check-set problems set-name)
(let ([missing (filter (lambda (x) x)
(map (lambda (problem) (if (problem-solution problem) #f (problem-name problem)))
problems))])
(set! total (+ (length problems) total))
(set! total-missing (+ (length missing) total-missing))
(unless (null? missing)
(printf "~a missing ~a~n" set-name (length missing))
(for-each (lambda (x) (printf " ~a~n" x)) missing))))
(for-each check-set problemss set-names)
(printf "missing ~a of ~a~n" total-missing total)))
(invoke-unit/sig
(compound-unit/sig (import)
(link
[problem : paint-by-numbers:problem^ ((require-library "problem.ss" "games" "paint-by-numbers"))]
[all : paint-by-numbers:all-problems^ ((require-library "all-problems.ss" "games" "paint-by-numbers") problem)]
[counter : () (counter problem all)])
(export)))

3317
collects/games/paint-by-numbers/raw-problems/raw-hattori.ss
View File

File diff suppressed because it is too large Load Diff

7
collects/games/paint-by-numbers/raw-problems/raw-kajitani.ss
View File

@ -1,4 +1,7 @@
(("Kajitani 15x15"
#lang scheme/base
(provide raw-kajitani)
(define raw-kajitani
'(("Kajitani 15x15"
"k15x15"
(("19980519-KHA (1)"
((2 2)
@ -14474,4 +14477,4 @@
(12)
(7)
()
())))))
()))))))

9
collects/games/paint-by-numbers/raw-problems/raw-misc.ss
View File

@ -1,6 +1,9 @@
#lang scheme/base
(provide raw-misc)
#|
raw-problems.ss
raw-misc.ss
This file contains the built-in problems in a raw format. It is
intended to be processed by the solver which will produce
@ -12,9 +15,8 @@ type:
The cols and rows types are specified in sig.ss
|#
(define raw-misc
`(
("Happy Happy Joy Joy"
((5) (9) (2 7) (4 8) (4 7) (6 7) (7 7) (7 6) (7 5) (5 1 4) (4 2 3) (2 4 1) (9) (5))
((4) (8) (10) (12) (1 8 1) (2 5 2) (4 3 3) (5 4) (7 5) (8 3) (9 1) (10 1) (10) (8) (4)))
@ -36,3 +38,4 @@ The cols and rows types are specified in sig.ss
((1) (2 2) (1 1) (1) (2 2) (1)))
)
)

5
collects/games/paint-by-numbers/raw-problems/raw-problems.ss
View File

@ -1,3 +1,5 @@
#lang scheme/base
#|
raw-problems.ss
@ -12,6 +14,8 @@ The cols and rows types are specified in sig.ss
|#
(provide raw-problems)
(define raw-problems
`(
("Izay (1)"
@ -75,3 +79,4 @@ The cols and rows types are specified in sig.ss
(2 4 2) (2 5) (5) (3) (3)))
)
)

8
collects/games/paint-by-numbers/raw-problems/size-calculation.ss
View File

@ -1,10 +1,6 @@
(require-library "function.ss")
(require-library "pretty.ss")
#lang scheme
(define raw-hattori (call-with-input-file
(build-path (collection-path "games" "paint-by-numbers")
"raw-hattori.ss")
(lambda (x) (eval (read x)))))
(require "raw-hattori.ss")
(define (num-possibilities size col)
(let* ([col-len (length col)]