fork download 
  1. #lang racket
  2.  
  3. (require 2htdp/universe 2htdp/image lang/posn)
  4. (require srfi/1)
  5. (require srfi/13)
  6. (require racket/struct)
  7. (require racket/match)
  8.  
  9. (struct WORLD (PLAYERS MAP PHASE TURN))
  10. (struct CARD (WOOD BLOCK IRON SHEEP))
  11.  
  12. (struct PLAYER (NO COLOR SCORE CARDS))
  13. (define test-cards (CARD 1 2 3 4))
  14. (define PLAYER-1 (PLAYER 1 "black" 0 test-cards))
  15.  
  16.  
  17. ;data;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. (define *map-zero* '(
  19.                      (1 2 3 4)
  20.                      (2 3 4 1)
  21.                      (3 4 1 2)
  22.                      (4 1 2 3)
  23.                      ))
  24.  
  25.  
  26. (define *cross-p* '(#f #f #f #f #f #f v1 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)) ;25
  27.  
  28. ;(define *roads-p* '(1 1 #f #f 1 #f #f #f #f 1 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
  29. ;                     #f #f #f #f #f #f #f #f #f #f 1 2 #f #f #f)) ;40
  30.  
  31. ;(define *roads-p* '(1 #f #f 1 #f 1 #f #f 1 1 #f #f #f 1 #f 1 1 #f #f #f 1 #f #f #f #f
  32. ;                     #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))
  33.  
  34. (define *roads-p* '(1 2 #f 1 #f 1 #f #f 1 1 1 #f #f 1 #f 1 1 1 1 #f 1 #f #f 1 1
  35.                      #f #f #f #f #f #f #f #f 1 #f #f #f #f #f #f)) ;
  36.  
  37. (define (x40 x y)
  38.   (make-posn (+ (* x 40) (* (- x 1) 40))
  39.              (+ (* y 40) (* (- y 1) 40))))
  40.  
  41.  
  42.  
  43.  
  44. ;補助関数;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45.  
  46. (define (tate&yoko x)
  47.   (cond ((<= x 4) 'yoko) 
  48.         ((<= 5 x 9) 'tate) ;(and (>= x 5) (<= x 9)) 'tate) 
  49.         ((<= 10 x 13) 'yoko) ; and (>= x 10) (<= x 13)) 'yoko)
  50.         ((<= 14 x 18) 'tate) ;(and (>= x 14) (<= x 18)) 'tate)
  51.         ((<= 19 x 22) 'yoko) ;(and (>= x 19) (<= x 22)) 'yoko)
  52.         ((<= 23 x 27) 'tate) ;(and (>= x 23) (<= x 27)) 'tate)
  53.         ((<= 28 x 31) 'yoko) ;(>= x 28) (<= x 31)) 'yoko)
  54.         ((<= 32 x 36) 'tate) ; (>= x 32) (<= x 36)) 'tate)
  55.         (else 'yoko)))
  56.  
  57. (define (tate&yokoX x)
  58.   (cond ((<= x 4) (+ 50 (* 80 (- x 1))))
  59.         ((<= 5 x 9) (+ 34 (* 80 (- x 5))))
  60.         ((<= 10 x 13) (+ 50 (* 80 (- x 10))))
  61.         ((<= 14 x 18) (+ 34 (* 80 (- x 14))))
  62.         ((<= 19 x 22) (+ 50 (* 80 (- x 19))))
  63.         ((<= 23 x 27) (+ 34 (* 80 (- x 23))))
  64.         ((<= 28 x 31) (+ 50 (* 80 (- x 28))))
  65.         ((<= 32 x 36)(+ 34 (* 80 (- x 32))))
  66.         (else (+ 50 (* 80 (- x 37))))))
  67.  
  68. (define (tate&yokoY x)
  69.     (cond ((<= x 4) 36)
  70.         ((<= 5 x 9)  50)
  71.         ((<= 10 x 13) 116)
  72.         ((<= 14 x 18) 130)
  73.         ((<= 19 x 22) 196)
  74.         ((<= 23 x 27)  210)
  75.         ((<= 28 x 31) 276)
  76.         ((<= 32 x 36) 290)
  77.         (else 356)))
  78.  
  79.  
  80. ;上下左右のポイントへ道が伸びているかをチェックする述語をそれぞれ別のクロージャで
  81. (define left (lambda (road-map c-point color)
  82.                (with-handlers ((exn:fail? (const #f))) (and
  83.                                                         (= color (list-ref road-map (- (+ (- c-point 1)
  84.                                                                    (* 4 (quotient (- c-point 1) 5))) 1)))
  85.                                                         (not (member c-point '(1 6 11 16 20))))))) ;
  86. (define up (lambda (road-map c-point color)
  87.               (with-handlers ((exn:fail? (const #f))) (and
  88.                                                        (= color (list-ref road-map (- (+ (- c-point 5)
  89.                                                                   (* 4 (quotient (- c-point 1) 5))) 1)))
  90.                                                         (not (member  c-point '(1 2 3 4 5)))))))
  91. (define right (lambda (road-map c-point color)
  92.                  (with-handlers ((exn:fail? (const #f))) (and
  93.                                                           (= color (list-ref road-map  (- (+ c-point
  94.                                                                      (* 4 (quotient (- c-point 1) 5))) 1)))
  95.                                                         (not (member c-point '(5 10 15 20 25)))))))
  96. (define down (lambda (road-map c-point color)
  97.                (with-handlers ((exn:fail? (const #f))) (and
  98.                                                         (= color (list-ref road-map (- (+ (+ c-point 4)
  99.                                                                    (* 4 (quotient (- c-point 1) 5))) 1)))
  100.                                                         (not (member c-point '(21 22 23 24 25)))))))
  101.  
  102.  
  103.  
  104.  
  105. ;町村が置けるかチェック関数;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  106.  
  107. ;隣り合う交点には町村を設置できない
  108.  
  109.  
  110. (define *cross-p2* '(#f #f #f #f v1 #f t1 #f #f #f #f #f #f #f v1 #f t1 #f #f #f #f #f #f #f #f)) ;25
  111. (define (tonari-VT? cross-map c-point) ;隣に町村がある？
  112.   (let ((c-num (- c-point 1)))
  113.   (if (or
  114.            (with-handlers ((exn:fail? (const #f))) (and (list-ref cross-map (- c-num 1)) (not (= 0 (remainder c-num 5)))))
  115.            (with-handlers ((exn:fail? (const #f))) (and (list-ref cross-map (- c-num 5)) (not (<= c-point 4)))) 
  116.            (with-handlers ((exn:fail? (const #f))) (and (list-ref cross-map (+ c-num 1)) (not (= 0 (remainder c-point 5)))))
  117.            (with-handlers ((exn:fail? (const #f))) (and (list-ref cross-map (+ c-num 5)) (not (>= c-point 21)))))
  118.       #t #f)))
  119.  
  120. ;(tonari-VT? *cross-p2* 16)
  121.  
  122. ;道が伸びてる交点にしか町村を設置できない
  123.  
  124. (define *roads-p2* '(1 1 #f #f #f #f #f #f 1 #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f 2
  125.                      #f #f #f #f #f 2 #f #f #f #f #f #f #f #f 1)) ;40
  126.  
  127. ;p2                  r #f 1 2 6       p4 #f 3 4 8         1-5    ?(-5) -1 0 4 gyou1 
  128. ;point7の場合　road6,10,11,15  P8 R7,11,12,16              6-10   -1 3 4 8 gyou2
  129. ;point12        r15,19,20,24      P13 r16,20,21,25        11-15  3 7 8 12 gyou3
  130. ;point17       r24 28 29 33      P18 r25 29 30 34         16-20  7 11 12 16 gyou4
  131. ;p22             r33 37 38 42                             21-25  11 15 16 20 gyou5
  132.  
  133.  
  134. (define (road-kiteru? road-map player c-point)
  135.   (let ((gyou-num (* 4 (quotient (- c-point 1) 5))) ;指定ポイントの存在する行数->行倍率で足す数
  136.         (c-num (- c-point 1))) ;list-ref用に変換したC-point
  137.   (if (or
  138.            (with-handlers ((exn:fail? (const #f))) (and (list-ref road-map (+ (- c-num 1) gyou-num));
  139.                                                         (not (= 0 (remainder c-num 5)))
  140.                                                         (= player (list-ref road-map (+ (- c-num 1) gyou-num))))) ;left
  141.            (with-handlers ((exn:fail? (const #f))) (and (list-ref road-map (+ (- c-num 5) gyou-num))
  142.                                                         (not (<= c-point 4))
  143.                                                         (= player (list-ref road-map (+ (- c-num 5) gyou-num))))) ;up
  144.            (with-handlers ((exn:fail? (const #f))) (and (list-ref road-map (+ c-num gyou-num))
  145.                                                         (not (= 0 (remainder c-point 5)))
  146.                                                         (= player (list-ref road-map (+ c-num gyou-num))))) ;right
  147.            (with-handlers ((exn:fail? (const #f))) (and (list-ref road-map (+ (+ c-num 4) gyou-num))
  148.                                                         (not (>= c-point 21))
  149.                                                         (= player (list-ref road-map (+ (+ c-num 4) gyou-num)))))) ;down
  150.       #t #f)))
  151.  
  152.  
  153. ;任意のポイントにに町村を作ることが出来るか？
  154. (define (can-build? cross-map road-map player c-point) ;playerが町村を作れる場所 list->list
  155.   (if (and (not (tonari-VT? cross-map c-point)) (road-kiteru? road-map player c-point)) #t #f))
  156.  
  157. ;(map (lambda (x) (can-build? *cross-p* *roads-p* 1 x)) (iota 25 1 1))
  158.  
  159.  
  160. ;ロンゲストロード関連;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  161.  
  162. ;上下左右チェッククロージャをリストにしておく
  163. (define check-funcs `(,left ,up ,right ,down))
  164.  
  165.  
  166. ;ポイントから伸びている道の数を返す
  167. (define (road-num roads c-point color)
  168.   (let ((gyou-num (* 4 (quotient (- c-point 1) 5))))
  169.     (let loop ((funcs check-funcs) (counter 0))
  170.       (if (null? funcs) counter
  171.           (loop (cdr funcs) (if ((car funcs) roads c-point color)
  172.                                 (+ counter 1) counter))))))
  173.  
  174.  
  175. ;伸びている道が1本であれば端と判定する
  176. (define (hazi? roads c-point color)
  177.   (if (= 1 (road-num roads c-point color)) #t #f))
  178.  
  179.  
  180.  
  181.  
  182. ;ポイントから道が伸びているポイントを返す ->list
  183. (define (dokohe? roads c-point color)
  184.   (flatten (for/list ((func check-funcs);上下左右が繋がっているかをチェックするクロージャのリスト
  185.              (change `(,(- c-point 1) ,(- c-point 5) ,(+ c-point 1) ,(+ c-point 5))));↑に対応する座標変化のリスト
  186.     (if (func roads c-point color) change '()))));本体
  187.  
  188.  
  189. ;ポイントから道路で繋がっているポイントをリストにする
  190. (define (roads-point-list roads c-point color)
  191.   (let loop ((c-point-d c-point) (point-list `(,c-point)) (pre-p c-point) (color color))
  192.     (cond ((and (not (= c-point (car point-list))) (hazi? roads c-point-d color)) (reverse point-list))
  193.         ;  ((member c-point-d point-list) (display (reverse point-list)));円環パターン終了
  194.           (else
  195.            (let ((num (remove (lambda (x) (= pre-p x)) (dokohe? roads c-point-d color))))
  196.                     (for/list ((num num))
  197.                       (loop num (cons num point-list) c-point-d color)))))))
  198.  
  199.  
  200. (roads-point-list *roads-p* 1 1)
  201.  
  202.  
  203. #|
  204. ;自作探索関数　（（あ））を探すため、動かず 後で動くようにしてみる？
  205. (define (tansaku lst acc)
  206.   (cond ((number? (car lst)) acc) ;数字まで到達したら終了
  207.         ((and (list? (car lst)) (number? (car (car lst)))) (tansaku (car lst) (cons (car lst) acc)));()に数字の入ってるリストが来たらAccに追加
  208.         ((not (null? (cdr lst))) (tansaku (car lst) acc)  (tansaku (cdr lst) acc));Cdr部がNullでなければCar、Cdrをそれぞれ再帰
  209.         ((and (list? (car lst)) (not (number? (car (car lst))))) (tansaku (car lst) acc))));Carで一段階中に入ってそのリストのCarが数字でなければCarで再帰
  210. |#
  211.  
  212. ;（（あ））を取り出して単一のリストにする関数
  213. (define (search-for-numbers lst)
  214.   (cond
  215.     [(null? lst) '()] ; リストが空の場合は空リストを返す
  216.     [(number? (car lst)) ; 先頭が数値の場合
  217.      (cons (car lst) (search-for-numbers (cdr lst)))] ; 数値を結果のリストに追加し、残りの部分に再帰
  218.     [(list? (car lst)) ; 先頭がリストの場合
  219.      (append (search-for-numbers (car lst)) (search-for-numbers (cdr lst)))] ; リスト内を再帰的に検索
  220.     [else
  221.      (search-for-numbers (cdr lst))])) ; それ以外の場合はスキップして次の要素を探索
  222.  
  223.  
  224. ;単一リストを任意の数値を頭にして複数のリストを作成
  225. (define (devide-numbers lst c-point)
  226.   (let loop ((lst lst) (acc '()) (temp '()))
  227.   (cond ((null? lst) (reverse (cons (reverse temp) acc)))
  228.         ((= (car lst) c-point) (loop (cdr lst) (if (null? temp) acc (cons (reverse temp) acc)) (list c-point)))
  229.         (else (loop (cdr lst) acc (cons (car lst) temp))))))
  230.  
  231. ;自分のロンゲストロードの最終的出力
  232. (define (my-longest-road roads c-point color)
  233.   (apply max (map (lambda (x) (- (length x) 1))
  234.                      (devide-numbers (search-for-numbers (roads-point-list roads c-point color)) c-point))))
  235.  
  236.  
  237.  
  238.  
  239.  
  240. ;画面表示関係;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  241. (define (place-map)
  242. (place-images/align
  243.  (map (lambda (x) (square 80 "solid"
  244.                          (case x
  245.                            ((1) "red")
  246.                            ((2) "white")
  247.                            ((3) "green")
  248.                            ((4) "yellow")
  249.                            (else "blue")))) (flatten *map-zero*))
  250.   (flatten (for/list ((i (iota 4 1 1)))
  251.              (for/list ((j (iota 4 1 1)))
  252.     (x40 i j)))) "left" "top"
  253.  (rectangle 800 400 "solid" "blue")))
  254.  
  255.  
  256. (define (place-road)
  257.   (place-images/align
  258.     (let loop ((lst *roads-p*) (count 1) (acc '()))
  259.       (if (null? lst)
  260.           (reverse acc)
  261.           (loop (cdr lst) (+ count 1) (if (car lst) (cons (case (tate&yoko count)
  262.                                                       ((yoko) (rectangle 60 10 "solid" (case (car lst)
  263.                                                                                          ((1) "black")
  264.                                                                                          ((2) "blue"))))
  265.                                                       ((tate) (rectangle 10 60 "solid" (case (car lst)
  266.                                                                                          ((1) "black")
  267.                                                                                          ((2) "blue"))))) acc)
  268.                                           acc))))
  269.     (let loopB ((lst *roads-p*) (count 1) (acc '()))
  270.       (if (null? lst)
  271.           (reverse acc)
  272.           (loopB (cdr lst) (+ count 1)
  273.                  (if (car lst)
  274.                       (cons (make-posn (tate&yokoX count) (tate&yokoY count)) acc)
  275.                        acc))))                                                         
  276.    "left" "top" (place-map)))
  277.  
  278.  
  279. (define (place-town)
  280.   (place-images/align
  281.    (let loopA ((lst *cross-p*) (acc '()))
  282.      (if (null? lst) (reverse acc)
  283.          (loopA (cdr lst) (if (car lst)
  284.                               (cons (case (car lst)
  285.                                       ((t1) (circle 10 "solid" "black"))
  286.                                       ((v1) (triangle 20 "solid" "black"))
  287.                                       (else (circle 10 "solid" "blue"))) acc)
  288.                               acc))))
  289.  
  290.    (let loopB ((lst *cross-p*) (count 1) (acc '()))
  291.      (if (null? lst) (reverse acc)
  292.          (loopB (cdr lst) (+ count 1) (if (car lst)
  293.                                           (cons (make-posn (+ 30 (* 80 (cond
  294.                                                                  ((= (remainder count 5) 0) 4) 
  295.                                                                  (else (- (remainder count 5) 1)))))
  296.                                                            (+ 28 (* 80 (cond
  297.                                                                  ((= (remainder count 5) 0) (- (quotient count 5) 1))
  298.                                                                  (else (quotient count 5))))))
  299.                                                               acc) acc))))
  300.  "left" "top" (place-road)))
  301.  
  302. (define number-list '(1 2 3 4 5 5 6 6 7 8 8 9 9 10 11 12))
  303. (define number-list-S (shuffle number-list))
  304.  
  305. (define (place-number)
  306.   (place-images/align  
  307.    (map (lambda (x) (text (number->string x) 25 "black")) number-list-S)
  308.    (let loopB ((lst number-list-S) (count 1) (acc '()))
  309.      (if (null? lst) (reverse acc)
  310.          (loopB (cdr lst) (+ count 1) 
  311.                                 (cons (make-posn (+ 70 (* 80 (cond
  312.                                                        ((= (remainder count 4) 0) 3) 
  313.                                                        (else (- (remainder count 4) 1)))))
  314.                                                  (+ 70 (* 80 (cond
  315.                                                        ((= (remainder count 4) 0) (- (quotient count 4) 1))
  316.                                                        (else (quotient count 4))))))
  317.                                                        acc)))) 
  318.    "left" "top" (place-town)))
  319.  
  320.  
  321.  
  322. (define (place-status)
  323.   (match-let (((PLAYER NO COLOR SCORE CARDS) PLAYER-1))
  324.   (match-let (((CARD WOOD BLOCK IRON SHEEP) CARDS))
  325.     (place-images/align
  326.      (list
  327.   (text (format "PLAYER~a" NO) 15 COLOR)
  328.   (text (format "CARDS 木:~a 土:~a 鉄:~a 羊:~a" WOOD BLOCK IRON SHEEP) 15 COLOR)
  329.   (text (format "SCORE: ~a" SCORE) 15 COLOR)
  330.   (text (format "MAX-ROAD-LENGTH: ~a" (my-longest-road *roads-p* 1 1)) 15 COLOR)
  331.   )
  332.     (list
  333.      (make-posn 420 40)
  334.      (make-posn 450 60)
  335.      (make-posn 450 80)
  336.      (make-posn 450 100)
  337.      )
  338.      "left" "top"
  339.     (place-image/align (rectangle 380 380 "solid" "white") 400 10 "left" "top" (place-number))))))
  340.  
  341.  
  342. ;(place-status)
  343.  
Success #stdin #stdout 1.39s 136588KB
comments (?)
stdin 
Standard input is empty
stdout 
Standard output is empty
https://ideone.com/DN9M8p
language:
Racket (racket 7.0)
created:
2 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!