Morpion solitaire: Difference between revisions
→{{header|Racket}}
m (=={{header|Racket}}== stub added) |
|||
Line 531:
=={{header|Racket}}==
<lang racket>#lang racket
(module rules racket/base
(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
(require racket/match
(submod ".." rules))
(provide play-game
random-line-chooser)
(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}}
Here is the text output of one run, and if you're (I'm) lucky, there's a picture attached:
<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>
=={{header|REXX}}==
| |||