アイコンの素

trilambda.scm

(use data.random)
(use gauche.generator)
(use srfi-1)
(use util.match)

; DEBUG {{{

(define (display-line obj . port)
  (let ((port (if (null? port) (current-output-port) port)))
    (display obj port)
    (newline port)))

(define (assert expr answer message)
  (if (equal? expr answer)
      #t
      (begin (display-line (string-append "assertion failed:" message)) #f)))

; }}}

; generate part {{{

;direction => f = forward | i = inverse

;tri => direction x y

;内部的に高さ1、幅2の三角形で処理(最低限これだけ必要かと)
;この段階で3点分のデータを持つのは無駄だし処理しづらいので頂点と向きだけ保持

(define (++ n)
  (+ n 1))

(define (-- n)
  (- n 1))

(define (move tri dir)
  (match tri
    (('f x y)
     (case dir
       ((:UP)    (list 'i x y))
       ((:DOWN)  (list 'i x (- y 2)))
       ((:LEFT)  (list 'i (-- x) (-- y)))
       ((:RIGHT) (list 'i (++ x) (-- y)))))
    (('i x y)
     (case dir
       ((:UP)    (list 'f x (+ y 2)))
       ((:DOWN)  (list 'f x y))
       ((:LEFT)  (list 'f (-- x) (++ y)))
       ((:RIGHT) (list 'f (++ x) (++ y)))))))

(define root '(f 0 1))
(define root-inv (move root :DOWN))

(define tri-mover (lambda (dir acc) (cons (move (car acc) dir) acc)))

(define (circular-take list count)
  (generator->list (apply circular-generator list) count))

(define lambda-up (reverse (fold tri-mover (list root) (circular-take '(:LEFT :UP) 4))))
(define lambda-left (cdr (reverse (fold tri-mover (list root) (circular-take '(:DOWN :LEFT) 6)))))
(define lambda-right (cddr (reverse (fold tri-mover (list root) (circular-take '(:DOWN :RIGHT) 6)))))
(define lambda-join (append lambda-up lambda-left lambda-right))

;三角形を一段階のシェルピンスキーのギャスケットにする、解像度が上がるので最初に2倍してる
;名前は、まあ生成してるものがトライ○ォースだからねぇ…
(define (tri-force tri acc)
  (let* ((root*2 (list (car tri) (* 2 (cadr tri)) (* 2 (caddr tri))))
         (root-inv (move root*2 (if (eq? (car root*2) 'f) :DOWN :UP)))
         (inv-left (move root-inv :LEFT))
         (inv-right (move root-inv :RIGHT)))
    (cons* root*2 root-inv inv-left inv-right acc)))

(assert (tri-force '(f 0 0) '()) '((f 0 0) (i 0 -2) (f -1 -1) (f 1 -1)) "tri-force:forward")
(assert (tri-force '(i 0 0) '()) '((i 0 0) (f 0 2) (i -1 1) (i 1 1)) "tri-force:inverse")

; }}}

; output-part {{{

;出力されるSVGのサイズ
(define svg-x "1000")
(define svg-y "1000")

(define (vertex->vec3 tri)
  (match tri
    (('f x y)
     (list (list x y) (list (-- x) (-- y)) (list (++ x) (-- y))))
    (('i x y)
     (list (list x y) (list (-- x) (++ y)) (list (++ x) (++ y))))))

;y軸を正三角形に変えると同時に数学的な+が上の座標からディスプレイの+が下な座標に直す
(define sqr3 (sqrt 3))
(define (vec3->equil v3)
  (map (lambda (v) (list (* 100 (car v)) (- (* 100 (cadr v) sqr3)))) v3))

(define lambda2 (fold tri-force '() lambda-join))

(define lambda-bg (list root))

(define lambda3
  (let* ((union (let rec ((i 0) (acc (list root)))
                  (if (= i 10)
                    acc
                    (rec (+ i 1) (delete-duplicates (fold (lambda (tri ac) (fold tri-mover (cons tri ac) '(:LEFT :UP :RIGHT :RIGHT :DOWN :DOWN :LEFT :LEFT))) '() acc))))))
         (triforce (fold tri-force '() union)))
    (lset-difference equal? triforce lambda2)))

(define lambda-data (map (.$ vec3->equil vertex->vec3) lambda2))
(define lambda-bg (map (.$ vec3->equil vertex->vec3) lambda3))

(define (vec3->points v3)
  (match v3
    (((x1 y1) (x2 y2) (x3 y3))
     (apply string-append (map x->string (list x1 "," y1 " " x2 "," y2 " " x3 "," y3))))))

(define (make-html-color rgb)
  (apply format (cons #f (cons "#~2,'0x~2,'0x~2,'0x" rgb))))

(define rng (integers$ 256))
(define rng-bg (integers$ 160))

;[v3] -> [(v3,color)]
(define colorized (map (lambda (v3) (cons v3 (make-html-color (let1 rn (rng) (list rn rn 255))))) lambda-data))
(define colorized-bg (map (lambda (v3) (cons v3 (make-html-color (let1 rn (rng-bg) (list 255 (+ 128 (quotient rn 2)) rn))))) lambda-bg))

(set! colorized (append colorized-bg colorized))

(define svg-body (map (lambda (v3-color)
                        (let ((v3 (car v3-color))
                              (color (cdr v3-color)))
                          `(polygon (@ (points ,(vec3->points v3)) (stroke ,color) (stroke-width "2px") (fill ,color))))) colorized))

(define svg `(svg (@ (xmlns "http://www.w3.org/2000/svg") (width ,svg-x) (height ,svg-y) (viewBox "-1500 -1500 3000 3000")) ,@svg-body))

(use sxml.serializer)

(display (srl:sxml->html svg) (open-output-file "/tmp/a.svg"))

; }}}