Hat tiling

hat.rkt

#lang racket

(require metapict)
(require metapict/pict)

(struct M-edge (turn) #:transparent)

(struct X+ M-edge () #:transparent)
(struct X- M-edge () #:transparent)
(struct A+ M-edge () #:transparent)
(struct A- M-edge () #:transparent)
(struct B+ M-edge () #:transparent)
(struct B- M-edge () #:transparent)
(struct F+ M-edge () #:transparent)
(struct F- M-edge () #:transparent)
(struct  L M-edge () #:transparent)

(define meta-H
  (list (X+ 0)
        (B- 1) (X- 1)
        (X+ 2)
        (B- 3) (X- 3)
        (X+ 4)
        (A+ 5) (X- 5)))

(define meta-T
  (list (A- 0)
        (A- 2)
        (B+ 4)))

(define meta-P
  (list (X+ 0) (A- 0)
        ( L 2) (X- 2)
        (X+ 3) (B+ 3)
        ( L 5) (X- 5)))

(define meta-F
  (list (X+ 0) (L 0) (X- 0)
        (F+ 1)
        (F- 2)
        (X+ 3) (B+ 3)
        ( L 5) (X- 5)))

(struct p-meta
  (meta turn dist) #:transparent)

(define meta-H~>
  (list (p-meta meta-H  0 (list (F- 1) (X+ 2) (B+ 2) (X- 1)))
        (p-meta meta-H -2 (list (F- 1) (X+ 2) (B+ 2) (X- 1)))
        (p-meta meta-H  0 (list (F- 1) (X+ 0) (B- 1) (X- 1)))
        (p-meta meta-T  0 (list (F- 1) (X+ 2) (B+ 2) (X- 1)
                                (X+ 0)))
        (p-meta meta-F -1 (list (F- 3) (X+ 2) (L 2) (X- 2)))
        (p-meta meta-F  1 (list (F- 1) (X+ 0) (B- 1) (X- 1)
                                (X+ 0) (L 0) (X- 0)))
        (p-meta meta-F  3 (list (F- 1) (X+ 2) (B+ 2) (X- 1)
                                (X+ 0) (B- 1) (X- 1) (X+ 2)
                                (L 2) (X- 2)))
        (p-meta meta-P  2 (list (F- 1) (X+ 2) (B+ 2) (X- 1)))
        (p-meta meta-P  1 (list (F- 1) (X+ 0) (L 0) (X- 0)))
        (p-meta meta-P  3 (list (F- 1) (X+ 0) (B- 1) (X- 1)
                                (X+ 0) (B- 1) (X- 1) (X+ 2)
                                (L 2) (X- 2)))))

(define meta-T~>
  (list (p-meta meta-H -1 (list (X- 2)))))

(define meta-P~>
  (list (p-meta meta-P 1 (list (F- 1) (X+ 0) (L 0) (X- 0)))
        (p-meta meta-H 5 (list (F- 1) (X+ 0) (L 0) (X- 0)))
        (p-meta meta-H 4 (list (F- 1) (X+ 2) (B+ 2) (X- 1)))
        (p-meta meta-F 5 (list (F- 3) (X+ 2) (L 2) (X- 2)))
        (p-meta meta-F 2 (list (F- 1) (X+ 0) (L 0) (X- 0)
                               (X+ -1) (B- 0) (X- 0) (X+ 1)
                               (L 1) (X- 1)))))

(define meta-F~>
  (list (p-meta meta-P 1 (list (F- 1) (X+ 0) (L 0) (X- 0)))
        (p-meta meta-H 5 (list (F- 1) (X+ 0) (L 0) (X- 0)))
        (p-meta meta-H 4 (list (F- 1) (X+ 2) (B+ 2) (X- 1)))
        (p-meta meta-F 5 (list (F- 3) (X+ 2) (L 2) (X- 2)))
        (p-meta meta-F 2 (list (F- 1) (X+ 0) (L 0) (X- 0)
                               (X+ -1) (B- 0) (X- 0) (X+ 1)
                               (L 1) (X- 1)))
        (p-meta meta-F 0 (list (F- 1) (X+ 0) (L 0) (X- 0)
                               (X+ -1) (L -1) (X- -1)))))

(define (M-edge-reps e)
  (let ([turn (M-edge-turn e)])
    (cond
     [(A-? e) (list (B- turn) (X- turn) (X+ (+ turn 1)))]
     [(A+? e) (list (X- (+ turn 1)) (X+ turn) (B+ turn))]
     [(B-? e) (list (X- (+ turn 1)) (X+ turn) (A- turn))]
     [(B+? e) (list (A+ turn) (X- turn) (X+ (+  turn 1)))]
     [(F-? e) (list (X+ turn) (L turn) (X- turn) (F+ (+ turn 1)))]
     [(F+? e) (list (F- (+ turn 1)) (X+ turn) (L turn) (X- turn))]
     [(L? e)  (list (L (- turn 1)))]
     [(X-? e) (list (X- (- turn 1)) (X+ turn) (L turn) (X- turn) (F+ (+ turn 1)))]
     [(X+? e) (list (F- (+ turn 1)) (X+ turn) (L turn) (X- turn) (X+ (- turn 1)))])))

(define (turn-M-edge e t)
  (cond
    [(A-? e) (A- (+ t (M-edge-turn e)))]
    [(A+? e) (A+ (+ t (M-edge-turn e)))]
    [(B-? e) (B- (+ t (M-edge-turn e)))]
    [(B+? e) (B+ (+ t (M-edge-turn e)))]
    [(F-? e) (F- (+ t (M-edge-turn e)))]
    [(F+? e) (F+ (+ t (M-edge-turn e)))]
    [( L? e) ( L (+ t (M-edge-turn e)))]
    [(X-? e) (X- (+ t (M-edge-turn e)))]
    [(X+? e) (X+ (+ t (M-edge-turn e)))]))

(define (substitute pm)
  (let ([o-turn     (p-meta-turn pm)]
        [o-dist     (p-meta-dist pm)]
        [o-meta     (p-meta-meta pm)])
    (map
     (lambda (p) (struct-copy p-meta p
                              [turn (+ o-turn (p-meta-turn p))]
                              [dist (append (apply append (map M-edge-reps o-dist))
                                            (map (lambda (e) (turn-M-edge e o-turn))
                                                 (p-meta-dist p)))]))
     (cond
       [(eq? o-meta meta-H) meta-H~>]
       [(eq? o-meta meta-T) meta-T~>]
       [(eq? o-meta meta-P) meta-P~>]
       [(eq? o-meta meta-F) meta-F~>]))))

(define (substitute-many p-metatiles)
  (apply append (map substitute p-metatiles)))

(define (scan init fn lst)
  (if (null? lst)
      (list init)
      (cons init
            (scan (fn init (first lst)) fn (rest lst)))))

(define (M-edge-length e)
  (cond
    [(or (A+? e) (A-? e) (B+? e) (B-? e)) 12]
    [else 4]))

(define (M-edges->curve origo turn edges)
  (let ([points (scan origo pt+
                      (map (lambda (e)
                             (pt@d (M-edge-length e)
                                   (* 60 (+ turn (M-edge-turn e)))))
                           edges))])
    (apply make-curve (append
                       (apply append (map (lambda (p) (list p --))
                                          (drop-right points 1)))
                       (list cycle)))))

(define (p-meta->curve m)
  (M-edges->curve
   (foldl pt+ (pt 0 0)
          (map (lambda (e)
                 (pt@d (M-edge-length e)
                       (* 60 (M-edge-turn e))))
               (p-meta-dist m)))
   (p-meta-turn m)
   (p-meta-meta m)))

(define (p-metas->curves pms)
  (map (lambda (m)
         (p-meta->curve m))
       pms))

(struct H-edge (turn) #:transparent)
(struct T1 H-edge ()  #:transparent)
(struct T2 H-edge ()  #:transparent)
(struct T3 H-edge ()  #:transparent)

(struct p-hat (dist turn flipped? shift) #:transparent)

(define (p-metatile->p-hat pm)
  (let ([m (p-meta-meta pm)]
        [t (p-meta-turn pm)]
        [o (p-meta-dist pm)])
    (cond
      [(eq? m meta-H) (list (p-hat o (- (* 2 t) 2) false 1)
                            (p-hat (append o
                                           (list (X+ t)
                                                 (B- (+ t 1))))
                                   (+ (* 2 t) 2) false 12)
                            (p-hat (append o
                                           (list (X+ (+ t 2))
                                                 (A- (+ t 2))))
                                   (+ (* 2 t) 2) false  7)
                            (p-hat (append o
                                           (list (X+ (+ t 2))
                                                 (L (+ t 2))
                                                 (L (+ t 1))))
                                   (remainder (* -1 (- (* -2 t) 4)) 12) true 6))]
      [(eq? m meta-T) (list (p-hat o (* 2 t) false 11))]
      [(eq? m meta-P) (list (p-hat o (- (* 2 t) 2) false 1)
                            (p-hat (append o
                                           (list (X- t)))
                                   (* 2 t) false 11))]
      [(eq? m meta-F) (list (p-hat o (- (* 2 t) 2) false 1)
                            (p-hat (append o
                                           (list (X- t)))
                                   (* 2 t) false 11))])))

(define hat
  (list (T1 -1) (T1 1) (T2 4) (T2 6) (T1 3)
        (T1 5) (T2 8) (T2 6) (T1 9) (T1 7)
        (T2 10) (T3 12) (T2 14)))

(define flipped-hat
  (list (T2 -2) (T3 0) (T2 2)
        (T1 5) (T1 3) (T2 6) (T2 4) (T1 7)
        (T1 9) (T2 6) (T2 8) (T1 11) (T1 1)))

(define (H-edge-length e)
  (cond
    [(T1? e)  (sqrt 12)]
    [(T2? e)         2]
    [(T3? e)         4]))

(define (H-edges->curve origo turn edges)
  (let ([points (scan origo pt+
                      (map (lambda (e)
                             (pt@d (H-edge-length e)
                                   (* 30 (+ turn (H-edge-turn e)))))
                           edges))])
    (apply make-curve (append
                       (apply append (map (lambda (p) (list p --))
                                          (drop-right points 1)))
                       (list cycle)))))


(define (shift xs s)
  (append (drop xs s)
          (take xs s)))

(define (p-hat->curve h)
  (H-edges->curve
   (foldl pt+ (pt 0 0)
          (map (lambda (e)
                 (pt@d (M-edge-length e)
                       (* 60 (M-edge-turn e))))
               (p-hat-dist h)))
   (p-hat-turn h)
   (if (p-hat-flipped? h)
       (shift flipped-hat (p-hat-shift h))
       (shift hat (p-hat-shift h)))))

(define (p-hats->curves phs)
  (map (lambda (h)
         (p-hat->curve h))
       phs))


(with-window (window -150 250 -50 350)
 (let ([ms (substitute-many
            (substitute-many
             (substitute-many
              (list (p-meta meta-H 0 (list))))))])
    (penwidth 0.1
              (scale 10
                     (draw (p-hats->curves
                            (apply append
                                   (map p-metatile->p-hat ms))))))))