Morpion solitaire: Difference between revisions
Content added Content deleted
m (=={{header|Racket}}== stub added) |
|||
Line 531: | Line 531: | ||
=={{header|Racket}}== |
=={{header|Racket}}== |
||
<lang racket> |
<lang racket>#lang racket |
||
(module rules racket/base |
|||
</lang> |
|||
(require racket/match) |
|||
(provide game-cross |
|||
available-lines |
|||
add-line |
|||
line-dx.dy) |
|||
(define (add-points points# x y . more) |
|||
(define p+ (hash-set points# (cons x y) #t)) |
|||
(if (null? more) p+ (apply add-points p+ more))) |
|||
;; original cross |
|||
(define (game-cross) |
|||
(let ((x1 (for/fold ((x (hash))) ((i (in-range 3 7))) |
|||
(add-points x 0 i i 0 9 i i 9)))) |
|||
(for/fold ((x x1)) ((i (in-sequences (in-range 0 4) (in-range 6 10)))) |
|||
(add-points x 3 i i 3 6 i i 6)))) |
|||
;; add an edge |
|||
(define (make-edge points#) |
|||
(for*/hash ((k (in-hash-keys points#)) |
|||
(dx (in-range -1 2)) |
|||
(dy (in-range -1 2)) |
|||
(x (in-value (+ (car k) dx))) |
|||
(y (in-value (+ (cdr k) dy))) |
|||
(e (in-value (cons x y))) |
|||
#:unless (hash-has-key? points# e)) |
|||
(values e #t))) |
|||
(define (line-dx.dy d) |
|||
(values (match d ['w -1] ['nw -1] ['n 0] [ne 1]) |
|||
(match d ['n -1] ['ne -1] ['nw -1] ['w 0]))) |
|||
(define (line-points e d) |
|||
(define-values (dx dy) (line-dx.dy d)) |
|||
(match-define (cons x y) e) |
|||
(for/list ((i (in-range 5))) |
|||
(cons (+ x (* dx i)) |
|||
(+ y (* dy i))))) |
|||
(define (line-overlaps? lp d l#) |
|||
(for/first ((i (in-range 3)) |
|||
(p (in-list (cdr lp))) |
|||
#:when (hash-has-key? l# (cons d p))) |
|||
#t)) |
|||
(define (four-points? lp p#) |
|||
(= 4 (for/sum ((p (in-list lp)) #:when (hash-has-key? p# p)) 1))) |
|||
;; returns a list of lines that can be applied to the game |
|||
(define (available-lines p# l# (e# (make-edge p#))) |
|||
(for*/list ((ep (in-sequences (in-hash-keys e#) (in-hash-keys p#))) |
|||
(d (in-list '(n w ne nw))) |
|||
(lp (in-value (line-points ep d))) |
|||
#:unless (line-overlaps? lp d l#) |
|||
#:when (four-points? lp p#)) |
|||
(define new-edge-point (for/first ((p (in-list lp)) #:when (hash-ref e# p #f)) p)) |
|||
(list ep d lp new-edge-point))) |
|||
;; adds a new line to points# lines# returns (values [new points#] [new lines#]) |
|||
(define (add-line line points# lines#) |
|||
(match-define (list _ dir ps _) line) |
|||
(for/fold ((p# points#) (l# lines#)) ((p (in-list ps))) |
|||
(values (hash-set p# p #t) (hash-set l# (cons dir p) #t))))) |
|||
(module player racket/base |
|||
_Intermission:_ The <code>render</code> submodule just does drawing, and is not part of the solving. But the <code>main</code> module uses it, so we put it in here: |
|||
(require racket/match |
|||
(submod ".." rules)) |
|||
(provide play-game |
|||
<lang racket> |
|||
random-line-chooser) |
|||
</lang> |
|||
(define (random-line-chooser p# l# options) |
|||
(list-ref options (random (length options)))) |
|||
;; line-chooser (points lines (Listof line) -> line) |
|||
(define (play-game line-chooser (o# (game-cross))) |
|||
(let loop ((points# o#) |
|||
(lines# (hash)) |
|||
(rv null)) |
|||
(match (available-lines points# lines#) |
|||
[(list) (values points# (reverse rv) o#)] |
|||
[options |
|||
(match-define (and chosen-one (list (cons x y) d _ new-edge-point)) |
|||
(line-chooser points# lines# options)) |
|||
(define-values (p# l#) (add-line chosen-one points# lines#)) |
|||
(loop p# l# (cons (vector x y d new-edge-point) rv))])))) |
|||
;; [Render module code goes here] |
|||
(module main racket/base |
|||
(require (submod ".." render) |
|||
(submod ".." player) |
|||
pict |
|||
racket/class) |
|||
(define p (call-with-values (λ () (play-game random-line-chooser)) render-state)) |
|||
p |
|||
(define bmp (pict->bitmap p)) |
|||
(send bmp save-file "images/morpion.png" 'png))</lang> |
|||
'''Intermission:''' The <code>render</code> submodule just does drawing, and is not part of the solving. But the <code>main</code> module uses it, so we put it in here: |
|||
<lang racket>(module render racket |
|||
(require racket/match |
|||
racket/draw |
|||
pict |
|||
(submod ".." rules)) |
|||
(provide display-state |
|||
render-state) |
|||
(define (min/max-point-coords p#) |
|||
(for/fold ((min-x #f) (min-y #f) (max-x #f) (max-y #f)) |
|||
((k (in-hash-keys p#))) |
|||
(match-define (cons x y) k) |
|||
(if min-x |
|||
(values (min min-x x) (min min-y y) (max max-x x) (max max-y y)) |
|||
(values x y x y)))) |
|||
(define (draw-text/centered dc x y t ->x ->y) |
|||
(define-values (w h b v) (send dc get-text-extent t)) |
|||
(send dc draw-text t (- (->x x) (* w 1/2)) (- (->y y) (* h 1/2)))) |
|||
(define ((with-stored-dc-context draw-fn) dc w h) |
|||
(define old-brush (send dc get-brush)) |
|||
(define old-pen (send dc get-pen)) |
|||
(define old-font (send dc get-font)) |
|||
(draw-fn dc w h) |
|||
(send* dc (set-brush old-brush) (set-pen old-pen) (set-font old-font))) |
|||
(define red-brush (new brush% [style 'solid] [color "red"])) |
|||
(define white-brush (new brush% [style 'solid] [color "white"])) |
|||
(define cyan-brush (new brush% [style 'solid] [color "cyan"])) |
|||
(define cyan-pen (new pen% [color "cyan"])) |
|||
(define black-pen (new pen% [color "black"])) |
|||
(define green-pen (new pen% [color "green"] [width 3])) |
|||
(define black-brush (new brush% [style 'solid] [color "black"])) |
|||
(define (render-state p# ls (o# (hash))) |
|||
(define-values (min-x min-y max-x max-y) (min/max-point-coords p#)) |
|||
(define C 24) |
|||
(define R 8) |
|||
(define D (* R 2)) |
|||
(define Rp 4) |
|||
(define (draw dc w h) |
|||
(define (->x x) (* C (- x min-x -1/2))) |
|||
(define (->y y) (* C (- y min-y -1/2 ))) |
|||
(send dc set-brush cyan-brush) |
|||
(send dc set-pen cyan-pen) |
|||
(send dc set-font (make-object font% R 'default)) |
|||
(for ((y (in-range min-y (add1 max-y)))) |
|||
(send dc draw-line (->x min-x) (->y y) (->x max-x) (->y y)) |
|||
(for ((x (in-range min-x (add1 max-x)))) |
|||
(send dc draw-line (->x x) (->y min-y) (->x x) (->y max-y)))) |
|||
(send dc set-pen black-pen) |
|||
(for ((l (in-list ls))) |
|||
(match-define (vector x y d (cons ex ey)) l) |
|||
(define-values (dx dy) (line-dx.dy d)) |
|||
(define x1 (+ x (* 4 dx))) |
|||
(define y1 (+ y (* 4 dy))) |
|||
(send* dc (draw-line (->x x) (->y y) (->x x1) (->y y1)))) |
|||
(for* ((y (in-range min-y (add1 max-y))) |
|||
(x (in-range min-x (add1 max-x)))) |
|||
(define k (cons x y)) |
|||
(cond [(hash-has-key? o# k) |
|||
(send dc set-brush red-brush) |
|||
(send dc draw-ellipse (- (->x x) R) (- (->y y) R) D D)] |
|||
[(hash-has-key? p# k) |
|||
(send dc set-brush white-brush) |
|||
(send dc draw-ellipse (- (->x x) R) (- (->y y) R) D D)])) |
|||
(send dc set-brush black-brush) |
|||
(for ((l (in-list ls)) |
|||
(i (in-naturals 1))) |
|||
(match-define (vector _ _ d (cons ex ey)) l) |
|||
(define-values (dx dy) (line-dx.dy d)) |
|||
(define R.dx (* R dx 0.6)) |
|||
(define R.dy (* R dy 0.6)) |
|||
(send* dc |
|||
(set-pen green-pen) |
|||
(draw-line (- (->x ex) R.dx) (- (->y ey) R.dy) (+ (->x ex) R.dx) (+ (->y ey) R.dy)) |
|||
(set-pen black-pen)) |
|||
(draw-text/centered dc ex ey (~a i) ->x ->y))) |
|||
(define P (dc (with-stored-dc-context draw) (* C (- max-x min-x -1)) (* C (- max-y min-y -1)))) |
|||
(printf "~s~%~a points ~a lines~%" ls (hash-count p#) (length ls)) |
|||
P) |
|||
(define (display-state p# l (o# (hash))) |
|||
(define-values (min-x min-y max-x max-y) (min/max-point-coords p#)) |
|||
(for ((y (in-range min-y (add1 max-y))) |
|||
#:when (unless (= y min-y) (newline)) |
|||
(x (in-range min-x (add1 max-x)))) |
|||
(define k (cons x y)) |
|||
(write-char |
|||
(cond [(hash-has-key? o# k) #\+] |
|||
[(hash-has-key? p# k) #\.] |
|||
[else #\space]))) |
|||
(printf "~s~%~a points ~a lines~%" l (hash-count p#) (length l))))</lang> |
|||
{{out}} |
{{out}} |
||
Here is the text output of one run, and if you're (I'm) lucky, there's a picture attached: |
Here is the text output of one run, and if you're (I'm) lucky, there's a picture attached: |
||
<pre> |
<pre> |
||
(#(9 6 n (9 . 2)) #(4 3 w (4 . 3)) #(7 9 w (7 . 9)) #(8 3 w (5 . 3)) #(3 9 n (3 . 5)) |
|||
#(0 7 n (0 . 7)) #(6 3 n (6 . -1)) #(7 0 w (7 . 0)) #(3 3 n (3 . -1)) #(4 6 w (4 . 6)) |
|||
#(2 6 ne (4 . 4)) #(6 9 n (6 . 5)) #(0 4 ne (2 . 2)) #(9 4 nw (7 . 2)) #(8 6 w (5 . 6)) |
|||
#(4 9 nw (2 . 7)) #(7 9 nw (5 . 7)) #(7 6 nw (5 . 4)) #(2 7 ne (4 . 5)) #(7 3 nw (5 . 1)) |
|||
#(5 7 n (5 . 5)) #(7 5 w (7 . 5)) #(5 6 ne (7 . 4)) #(6 7 nw (3 . 4)) #(0 7 ne (2 . 5)) |
|||
#(7 7 nw (7 . 7)) #(6 8 ne (10 . 4)) #(2 6 n (2 . 4)) #(5 7 ne (8 . 4)) #(5 4 w (1 . 4)) |
|||
#(1 4 ne (4 . 1)) #(7 7 w (4 . 7)) #(4 9 n (4 . 8)) #(7 4 n (7 . 1)) #(7 4 nw (5 . 2)) |
|||
#(11 4 w (11 . 4)) #(7 9 n (7 . 8)) #(5 3 n (5 . -1)) #(7 2 w (4 . 2)) #(8 6 nw (6 . 4)) |
|||
#(7 8 w (5 . 8)) #(3 10 ne (3 . 10)) #(5 9 nw (1 . 5)) #(4 3 ne (8 . -1)) |
|||
#(-1 7 ne (-1 . 7)) #(1 6 n (1 . 2)) #(6 1 w (2 . 1)) #(10 4 nw (8 . 2)) #(3 5 w (-1 . 5)) |
|||
#(8 6 n (8 . 5)) #(-1 4 ne (-1 . 4)) #(5 5 ne (9 . 1)) #(3 6 nw (-1 . 2)) #(3 3 ne (7 . -1)) |
|||
#(7 -1 w (4 . -1)) #(7 10 nw (7 . 10)) #(3 2 w (0 . 2)) #(3 5 nw (-1 . 1)) #(-1 5 n (-1 . 3)) |
|||
#(3 7 w (1 . 7)) #(3 9 nw (2 . 8)) #(1 9 ne (1 . 9)) #(4 2 n (4 . -2))) |
|||
99 points 63 lines |
|||
</pre> |
</pre> |
||
=={{header|REXX}}== |
=={{header|REXX}}== |