Skip to content

Instantly share code, notes, and snippets.

@rdivyanshu

rdivyanshu/hat.rkt

Last active September 21, 2023 09:40
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save rdivyanshu/2d71e604917aa4893a701ca7f71c67b4 to your computer and use it in GitHub Desktop.
Save rdivyanshu/2d71e604917aa4893a701ca7f71c67b4 to your computer and use it in GitHub Desktop.
Download ZIP
Hat tiling
Raw
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))))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment