PasteRack.org
Paste # 83653
2022-06-13 05:56:30

Fork as a new paste.

Paste viewed 903 times.


Embed:

two rings puzzle

  1. #lang racket
  2.  
  3. (require 2htdp/image)
  4.  
  5. (define (rpush x xs)
  6.   (values (first xs) (append (rest xs) (list x))))
  7.  
  8. ;; (rpush 10 '(1 2 3))
  9. ;; => 1
  10. ;; => '(2 3 10)
  11.  
  12. (define (lpush x xs)
  13.   (let-values ([(r l) (split-at-right xs 1)])
  14.     (values (first l) (cons x r))))
  15.  
  16. ;; (lpush 10 '(1 2 3))
  17. ;; => 3
  18. ;; => '(10 1 2)
  19.  
  20. (define-struct rings (t b li le ri re) #:transparent)
  21.  
  22. (define initial-state
  23.   (make-rings 'r 'r
  24.               (make-list 3 'r) (make-list 7 'r)
  25.               (make-list 3 'b) (make-list 7 'b)))
  26.  
  27. (define (left-ring r)
  28.   (append (cons (rings-t r) (rings-li r))
  29.           (cons (rings-b r) (rings-le r))))
  30.  
  31. (define (right-ring r)
  32.   (append (cons #f (rings-ri r))
  33.           (cons #f (rings-re r))))
  34.  
  35. (define (rotate-ll r)
  36.   (let-values ([(new-t new-li) (rpush (rings-b r) (rings-li r))]
  37.                [(new-b new-le) (rpush (rings-t r) (rings-le r))])
  38.     (struct-copy rings r
  39.                  [t new-t] [b new-b]
  40.                  [li new-li] [le new-le])))
  41.  
  42. (define (rotate-lr r)
  43.   (let-values ([(new-b new-li) (lpush (rings-t r) (rings-li r))]
  44.                [(new-t new-le) (lpush (rings-b r) (rings-le r))])
  45.     (struct-copy rings r
  46.                  [t new-t] [b new-b]
  47.                  [li new-li] [le new-le])))
  48.  
  49. (define (rotate-rr r)
  50.   (let-values ([(new-t new-ri) (rpush (rings-b r) (rings-ri r))]
  51.                [(new-b new-re) (rpush (rings-t r) (rings-re r))])
  52.     (struct-copy rings r
  53.                  [t new-t] [b new-b]
  54.                  [ri new-ri] [re new-re])))
  55.  
  56. (define (rotate-rl r)
  57.   (let-values ([(new-b new-ri) (lpush (rings-t r) (rings-ri r))]
  58.                [(new-t new-re) (lpush (rings-b r) (rings-re r))])
  59.     (struct-copy rings r
  60.                  [t new-t] [b new-b]
  61.                  [ri new-ri] [re new-re])))
  62.  
  63. ;; (rotate-rl (rotate-rr initial-state)) == initial-state
  64.  
  65. (define (ring-image xs)
  66.   (foldr (λ (x s)
  67.            (rotate 30 (if (not x) s
  68.                           (overlay/offset
  69.                            (circle 10 'solid
  70.                                    (if (eq? x 'r) 'red 'blue))
  71.                            0 100
  72.                            s))))
  73.          (circle 110 0 'black)
  74.          xs))
  75.  
  76. (define (rings-image r)
  77.   (overlay/offset
  78.    (flip-horizontal (ring-image (left-ring r)))
  79.    100 0
  80.    (ring-image (right-ring r))))
  81.  
  82. (rings-image (rotate-lr (rotate-rr initial-state)))

=>

image