Word search: Difference between revisions
→{{header|Racket}}
(→=={{header|Racket}}==: stub added) |
|||
Line 1,393:
=={{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}}==
| |||