Word search: Difference between revisions
Content added Content deleted
(→=={{header|Racket}}==: stub added) |
|||
Line 1,393: | Line 1,393: | ||
=={{header|Racket}}== |
=={{header|Racket}}== |
||
{{trans|Java}} |
|||
(or at least it started out that way... so more "inspired by") |
|||
<lang racket>#lang racket |
|||
;; --------------------------------------------------------------------------------------------------- |
|||
(module+ main |
|||
(display-puzzle (create-word-search)) |
|||
(newline) |
|||
(parameterize ((current-min-words 50)) |
|||
(display-puzzle (create-word-search #:n-rows 20 #:n-cols 20)))) |
|||
;; --------------------------------------------------------------------------------------------------- |
|||
(define current-min-words (make-parameter 25)) |
|||
;; --------------------------------------------------------------------------------------------------- |
|||
(define (all-words pzl) |
|||
(filter-map (good-word? pzl) (file->lines "data/unixdict.txt"))) |
|||
(define (good-word? pzl) |
|||
(let ((m (puzzle-max-word-size pzl))) |
|||
(λ (w) (and (<= 3 (string-length w) m) (regexp-match #px"^[A-Za-z]*$" w) (string-downcase w))))) |
|||
(struct puzzle (n-rows n-cols cells solutions) #:transparent) |
|||
(define puzzle-max-word-size (match-lambda [(puzzle n-rows n-cols _ _) (max n-rows n-cols)])) |
|||
(define dirs '((-1 -1 ↖) (-1 0 ↑) (-1 1 ↗) (0 -1 ←) (0 1 →) (1 -1 ↙) (1 0 ↓) (1 1 ↘))) |
|||
;; --------------------------------------------------------------------------------------------------- |
|||
(define (display-puzzle pzl) (displayln (puzzle->string pzl))) |
|||
(define (puzzle->string pzl) |
|||
(match-let* |
|||
(((and pzl (puzzle n-rows n-cols cells (and solutions (app length size)))) pzl) |
|||
(column-numbers (cons "" (range n-cols))) |
|||
(render-row (λ (r) (cons r (map (λ (c) (hash-ref cells (cons r c) #\_)) (range n-cols))))) |
|||
(the-grid (add-between (map (curry map (curry ~a #:width 3)) |
|||
(cons column-numbers (map render-row (range n-rows)))) "\n")) |
|||
(solutions§ (solutions->string (sort solutions string<? #:key car)))) |
|||
(string-join (flatten (list the-grid "\n\n" solutions§)) ""))) |
|||
(define (solutions->string solutions) |
|||
(let* ((l1 (compose string-length car)) |
|||
(format-solution-to-max-word-size (format-solution (l1 (argmax l1 solutions))))) |
|||
(let recur ((solutions solutions) (need-newline? #f) (acc null)) |
|||
(if (null? solutions) |
|||
(reverse (if need-newline? (cons "\n" acc) acc)) |
|||
(let* ((spacer (if need-newline? "\n" " ")) |
|||
(solution (format "~a~a" (format-solution-to-max-word-size (car solutions)) spacer))) |
|||
(recur (cdr solutions) (not need-newline?) (cons solution acc))))))) |
|||
(define (format-solution max-word-size) |
|||
(match-lambda [(list word row col dir) |
|||
(string-append (~a word #:width (+ max-word-size 1)) |
|||
(~a (format "(~a,~a ~a)" row col dir) #:width 9))])) |
|||
;; --------------------------------------------------------------------------------------------------- |
|||
(define (create-word-search #:msg (msg "Rosetta Code") #:n-rows (n-rows 10) #:n-cols (n-cols 10)) |
|||
(let* ((pzl (puzzle n-rows n-cols (hash) null)) |
|||
(MSG (sanitise-message msg)) |
|||
(n-holes (- (* n-rows n-cols) (string-length MSG)))) |
|||
(place-message (place-words pzl (shuffle (all-words pzl)) (current-min-words) n-holes) MSG))) |
|||
(define (sanitise-message msg) (regexp-replace* #rx"[^A-Z]" (string-upcase msg) "")) |
|||
(define (place-words pzl words needed-words holes) |
|||
(let inner ((pzl pzl) (words words) (needed-words needed-words) (holes holes)) |
|||
(cond [(and (not (positive? needed-words)) (zero? holes)) pzl] |
|||
[(null? words) |
|||
(eprintf "no solution... retrying (~a words remaining)~%" needed-words) |
|||
(inner pzl (shuffle words) needed-words)] |
|||
[else |
|||
(let/ec no-fit |
|||
(let*-values |
|||
(([word words...] (values (car words) (cdr words))) |
|||
([solution cells′ holes′] |
|||
(fit-word word pzl holes (λ () (no-fit (inner pzl words... needed-words holes))))) |
|||
([solutions′] (cons solution (puzzle-solutions pzl))) |
|||
([pzl′] (struct-copy puzzle pzl (solutions solutions′) (cells cells′)))) |
|||
(inner pzl′ words... (sub1 needed-words) holes′)))]))) |
|||
(define (fit-word word pzl holes fail) |
|||
(match-let* (((puzzle n-rows n-cols cells _) pzl) |
|||
(rows (shuffle (range n-rows))) |
|||
(cols (shuffle (range n-cols))) |
|||
(fits? (let ((l (string-length word))) (λ (maxz z0 dz) (< -1 (+ z0 (* dz l)) maxz))))) |
|||
(let/ec return |
|||
(for* ((dr-dc-↗ (shuffle dirs)) |
|||
(r0 rows) (dr (in-value (car dr-dc-↗))) #:when (fits? n-rows r0 dr) |
|||
(c0 cols) (dc (in-value (cadr dr-dc-↗))) #:when (fits? n-cols c0 dc) |
|||
(↗ (in-value (caddr dr-dc-↗)))) |
|||
(let/ec retry/ec (attempt-word-fit pzl word r0 c0 dr dc ↗ holes return retry/ec))) |
|||
(fail)))) |
|||
(define (attempt-word-fit pzl word r0 c0 dr dc ↗ holes return retry) |
|||
(let-values (([cells′ available-cells′] |
|||
(for/fold ((cells′ (puzzle-cells pzl)) (holes′ holes)) |
|||
((w word) (i (in-naturals))) |
|||
(define k (cons (+ r0 (* dr i)) (+ c0 (* dc i)))) |
|||
(cond [(not (hash-has-key? cells′ k)) |
|||
(if (zero? holes′) (retry) (values (hash-set cells′ k w) (sub1 holes′)))] |
|||
[(char=? (hash-ref cells′ k) w) (values cells′ holes′)] |
|||
[else (retry)])))) |
|||
(return (list word r0 c0 ↗) cells′ available-cells′))) |
|||
;; --------------------------------------------------------------------------------------------------- |
|||
(define (place-message pzl MSG) |
|||
(match-define (puzzle n-rows n-cols cells _) pzl) |
|||
(struct-copy puzzle pzl |
|||
(cells |
|||
(let loop ((r 0) (c 0) (cells cells) (msg (string->list MSG))) |
|||
(cond [(or (null? msg) (= r n-rows)) cells] |
|||
[(= c n-cols) (loop (add1 r) 0 cells msg)] |
|||
[(hash-has-key? cells (cons r c)) (loop r (add1 c) cells msg)] |
|||
[else (loop r (add1 c) (hash-set cells (cons r c) (car msg)) (cdr msg))]))))) |
|||
</lang> |
|||
{{out}} |
|||
<pre> 0 1 2 3 4 5 6 7 8 9 |
|||
0 R s o y b e a n O p |
|||
1 r d h t a b e S e r |
|||
2 o e n a o h k n l u |
|||
3 t t y o r a i e i s |
|||
4 a e r u r n d g a s |
|||
5 r s E m s e n T l e |
|||
6 i t a u c i h T f l |
|||
7 a A l e l l o y l l |
|||
8 n a r s e r a l a C |
|||
9 O p D l u m e n c E |
|||
ail (4,8 ↑) air (7,0 ↑) |
|||
are (8,6 ←) aye (2,3 ↙) |
|||
bath (1,5 ←) boor (1,5 ↙) |
|||
calf (9,8 ↑) detest (1,1 ↓) |
|||
est (4,1 ↓) flail (6,8 ↑) |
|||
heron (6,6 ↖) karma (2,6 ↙) |
|||
lares (8,7 ←) loy (7,5 →) |
|||
lumen (9,3 →) nehru (0,7 ↙) |
|||
peninsula (0,9 ↙) precede (9,1 ↗) |
|||
rotarian (1,0 ↓) roy (3,4 ←) |
|||
russell (1,9 ↓) sling (8,3 ↗) |
|||
soybean (0,1 →) tab (1,3 →) |
|||
tar (3,0 ↓) |
|||
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
|||
0 e o w e d i r o u l f a r t e t n i u q |
|||
1 x R a i n o n i o k O y t n e l p o o p |
|||
2 i a l b a o h u n o i t a t r e s s i d |
|||
3 s r s u v u n g o d d e s s o b a S y r |
|||
4 t m e d r s h e g n a m i n o l y e r a |
|||
5 c o x t b o n E t c a t r r t o c a u n |
|||
6 n n y u a y o e i i n e p a y w n v b k |
|||
7 i k r r u p r f d a s h d m l b e e n c |
|||
8 t y d e e n i b r d i i e n n a g s a a |
|||
9 s T a t v t d g t c a n v r a c r d d t |
|||
10 i a a m a l n T h t e s f f o k u r A a |
|||
11 d b n e e w a n o i t a s r e v n o c l |
|||
12 a l b g r h s h n e s t h e r d d p a i |
|||
13 r a t t u a c o g e l g g o b e C p l n |
|||
14 t r e r n m d s l t n d d u r s a e c a |
|||
15 n r l a a a t n h i r o d b O t n d u v |
|||
16 o e c u m a t g a a d g l e x i c a l i |
|||
17 c f r m n l i t b g e y r u b n e s u d |
|||
18 o e i a s l a b y t i l a u q y a w s j |
|||
19 h r c a s s i l e m D l k c o b b u l E |
|||
abate (12,0 ↗) alarm (8,15 ↖) |
|||
alba (2,1 →) alma (18,6 ↖) |
|||
amino (4,10 →) andean (9,14 ↖) |
|||
andiron (11,6 ↑) ann (8,15 ←) |
|||
armonk (2,1 ↓) balsa (18,7 ←) |
|||
beatific (12,2 ↗) blowback (3,15 ↓) |
|||
bock (19,15 ←) boggle (13,14 ←) |
|||
bred (15,13 ↗) bud (2,3 ↓) |
|||
budget (13,14 ↙) calculus (11,18 ↓) |
|||
catalina (7,19 ↓) circlet (19,2 ↑) |
|||
clot (5,16 ↖) contradistinct (17,0 ↑) |
|||
conversation (11,18 ←) danbury (9,18 ↑) |
|||
destiny (12,15 ↓) dissertation (2,19 ←) |
|||
dodo (16,10 ↗) drab (14,11 ↙) |
|||
drank (2,19 ↓) dusenbury (17,19 ←) |
|||
eavesdropped (4,17 ↓) enemy (10,10 ↗) |
|||
esther (12,9 →) exist (0,0 ↓) |
|||
goddess (3,7 →) grant (9,7 ↗) |
|||
halve (12,7 ↖) hero (7,11 ↘) |
|||
hoard (4,6 ↙) hoc (19,0 ↑) |
|||
hurty (2,6 ↙) ivan (16,19 ↑) |
|||
juan (18,19 ↖) koinonia (1,9 ←) |
|||
lexical (16,12 →) ligand (19,11 ↖) |
|||
lone (16,12 ↖) lounsbury (0,9 ↙) |
|||
lubbock (19,18 ←) mange (4,11 ←) |
|||
manure (16,4 ↑) melissa (19,9 ←) |
|||
natty (14,4 ↘) nib (8,5 →) |
|||
nyu (5,6 ↙) offset (10,14 ←) |
|||
orphic (4,14 ↙) owe (0,1 →) |
|||
pay (6,12 →) plenty (1,16 ←) |
|||
poop (1,19 ←) purr (7,5 ←) |
|||
quality (18,14 ←) quintet (0,19 ←) |
|||
rca (9,16 ←) read (12,14 ↘) |
|||
referral (19,1 ↑) sadden (10,11 ↖) |
|||
salt (2,17 ↙) sang (9,0 ↘) |
|||
schema (14,7 ↖) sexy (3,2 ↓) |
|||
slight (19,4 ↗) solid (12,6 ↘) |
|||
stan (14,7 ↙) tern (5,8 ↙) |
|||
tetrafluoride (0,15 ←) thong (9,8 ↓) |
|||
trauma (13,3 ↓) urgency (10,16 ↑) |
|||
visit (9,12 ↖) von (3,4 ↗) |
|||
way (18,17 ←) wham (11,5 ↓) </pre> |
|||
=={{header|zkl}}== |
=={{header|zkl}}== |