Examples/ハート曲線を描く

おまけです。レイアウトでハート型にパスを描きます。社内恋愛、エイプリルフールネタなどにご活用下さい。( ´艸｀)ﾌﾟﾌﾟｯ

; -----------------------------------------------------------------------------
; (jp_wikiwiki_aiou_createHeartCurve cellview layerPurpose width bBox)
; -----------------------------------------------------------------------------
; ハート型にパスを描きます。
;   cellview : 描画対象のセルビュー。
;   layerPurpose : 描画するパスのレイヤー名とパーパス名を要素とするリスト。
;                  （赤めの色のレイヤーをおすすめします。）
;   width : 描画するパスの幅。
;   bBox : 描画するハートが外接する四角形の座標（対向する二つの頂点のリスト）
;
; 《例》 対象は現在開いているセルビューの (0.0, 0.0) - (20.0, 18.0) の矩形領域に、
; 　　　 幅 0.5 の text:drawing レイヤーのパスでハート形状を描く。
;
;   (ja_wikiwiki_aiou_createHeartCurve
;     (hiGetCurrentWindow)~>cellView '("text" "drawing") 0.5 '((0.0 0.0) (20.0 18.0))
;   )
; -----------------------------------------------------------------------------
(define (jp_wikiwiki_aiou_createHeartCurve cellview layerPurpose width bBox)
  (letseq
    (
    (heartCurve (Points_generateHeartCurve bBox))
    (prev (car heartCurve))
    (paths nil)
    )
    (foreach p (cdr heartCurve)
      (setq paths (cons (dbCreatePath cellview layerPurpose (list prev p) width) paths))
      (setq prev p)
    )
    (setq paths (cons (dbCreatePath cellview layerPurpose (list prev (car heartCurve)) width) paths))
    paths
  )
)

; -----------------------------------------------------------------------------
; (Points_generateHeartCurve boundaryRect [b])
; -----------------------------------------------------------------------------
; ハート型の点列を生成する汎用の関数。点列を順になぞると一筆書きのハート形状になる。
;   boundaryRect : 描画するハートが外接する四角形の座標（対向する二つの頂点のリスト）
;   b : ハートの形状を微調整するパラメーター。省略可能。規定値は 1.0。
;
; 《例》 (0.0, 0.0) - (20.0, 15.0) の矩形領域に外接するハート形状の点を生成する。
;
;   (Points_generateHeartCurve '((0.0 0.0) (20.0 15.0)))
;
; -----------------------------------------------------------------------------
; ※ 参考資料: http://www16.ocn.ne.jp/~akiko-y/heart/index_heart.html
; -----------------------------------------------------------------------------

(define (Points_generateHeartCurve boundaryRect @optional (b 1.0))
  (letseq
    (
    (heartCurve
      (let
        ((buffer nil) (pi (acos -1.0)) (theta 0))
        (while (lessp theta 360)
          (letseq
            (
            (x (cos (times pi (quotient theta 180.0))))
            (yb (times b (sqrt (abs x))))
            (ya (sqrt (difference 1.0 (times x x))))
            (y (if (lessp theta 180) (plus yb ya) (difference yb ya)))
            )
            (setq buffer (cons (list x y) buffer))
          )
          (setq theta (plus theta 5))
        )
        buffer
      )
    )
    (heartCurve_ys (mapcar 'cadr heartCurve))
    (heartCurve_ymin (apply 'min heartCurve_ys))
    (heartCurve_ymax (apply 'max heartCurve_ys))
    (heartCurve_yc (quotient (plus       heartCurve_ymax heartCurve_ymin) 2.0))
    (heartCurve_hH (quotient (difference heartCurve_ymax heartCurve_ymin) 2.0))
    (unitHeartCurve
      (mapcar
        (lambda (point)
          (list
            (car point)
            (quotient (difference (cadr point) heartCurve_yc) heartCurve_hH)
          )
        )
        heartCurve
      )
    )
    (xs (mapcar 'car  boundaryRect)) (width  (abs (apply 'difference xs))) (xmin (apply 'min xs))
    (ys (mapcar 'cadr boundaryRect)) (height (abs (apply 'difference ys))) (ymin (apply 'min ys))
    )
    (mapcar
      (lambda (point)
        (list
          (plus xmin (times (plus (car  point) 1.0) 0.5 width ))
          (plus ymin (times (plus (cadr point) 1.0) 0.5 height))
        )
      )
      unitHeartCurve
    )
  )
)