PasteRack.org
Paste # 50720
2019-09-03 06:03:01

Fork as a new paste.

Paste viewed 453 times.


Embed:

Reverse engineered quilt design

#lang racket

(require threading
         "quilt.rkt")

;; EXAMPLES
;;

;; Build a super-duper quilt from rectangles, hsts, squares, and a
;; few qsts

(define qst_ (qst 1 'black 'white))
(define qst__ (qst 1 'black 'black 'black 'white))
(define hst_ (hst 1 'black 'white 'forward))

(define (around-the-world . ss)
  ; error on (< (length ss) 3)
  (define ts (map (λ (s)
                    (if (symbol? s)
                        (square 1 s)
                        s))
                  ss))
  
(let around ([n(- (* 2 (length ss)) 3)])
  (define half (/ (- n 1) 2))
  (if (= n 3)
      (apply surround (take ts 3))
      (let* ([ps (take (drop ts half) (min (+ half 1)
                                           (- (length ts) half)))]
             [center (first ps)]
             [corner (last ps)]
             [ts (rest (reverse (rest ps)))]
             [side (apply beside 
                          (append (make-list (- half (length ts) 1)
                                             corner)
                                  ts))])
        (surround (around (- n 2))
                  (reflect side center)
                  corner)))))

(define (diamond center [surround 'white])
  (4-square (hst 1 surround center 'forward) R))

(define hst-strip
  (~> (reflect (beside/n 4 hst_) qst__)
      (B (H hst_))
      reflect))
    
(define b1 (around-the-world 'black
                             qst_
                             'cerise
                             'lupine
                             'caribbean
                             hst_))

(define b2 (around-the-world 'black
                             qst_
                             'amber
                             'cactus
                             'maize
                             hst_))

(define diamond-strip
  (beside/n 11 (diamond 'black) (diamond 'caribbean)))

(define geese
  (beside/n 9 (A (V hst_) hst_)))

(define quilt
  (~> (grid [b1 (R geese) b2]
            [geese (diamond 'maize 'cactus) (H geese)]
            [b2 (L geese) b1])
      (surround hst-strip hst_)
      (surround diamond-strip (diamond 'caribbean))
      (add-strips 'cactus)
      (add-strips 'caribbean)
      (add-strips 'black)))


(parameterize ([units 20]
               [show-outline #t])
  (draw quilt))

=>

standard-module-name-resolver: collection not found
  for module path: threading
  collection: "threading"
  in collection directories:
   /home/pasterack/.racket/7.3/collects
   /home/pasterack/racket73/collects
   ... [166 additional linked and package directories]
  context...:
   show-collection-err
   standard-module-name-resolver
   syntax-local-module-exports
   /home/pasterack/racket73/collects/racket/require-transform.rkt:266:2: expand-import
   /home/pasterack/racket73/collects/racket/private/reqprov.rkt:571:24
   /home/pasterack/racket73/collects/racket/private/reqprov.rkt:559:5
   /home/pasterack/racket73/collects/racket/require-transform.rkt:266:2: expand-import
   /home/pasterack/racket73/collects/racket/private/reqprov.rkt:266:21: try-next
   /home/pasterack/racket73/collects/racket/private/reqprov.rkt:348:21: try-next
   /home/pasterack/racket73/collects/racket/private/reqprov.rkt:243:2: require
   apply-transformer-in-context
   apply-transformer52
   dispatch-transformer41
   do-local-expand50
   /home/pasterack/racket73/collects/syntax/wrap-modbeg.rkt:46:4: do-wrapping-module-begin
   apply-transformer-in-context
   ...