黄金比や白銀比，青銅比などの貴金属比でパラメータを分割して一覧を出力するGaucheスクリプト

metallic-split.scm

#!/usr/bin/env gosh
#|
 Metallic Ratio Split

 <USAGE>
 1. Research Splited Values by metallic ratio
 $ gosh metallic-split.scm 960

 2. Generate CSS Format
 $ gosh metallic-split.scm -c -b 1 -p 10 960 > style.css
 $ gosh metallic-split.scm -r golden -c -b 2 -p 10 960 > golden_ratio.css

 <OPTION>
 -r | --ratio (defalut all) : select metallic ratio (golden | silver | bronze)
 -c | --css : stdout to css
 -b | --border : border-line stroke weight for css
 -p | --padding : padding px for css
|#

(use srfi-1)
(use gauche.parseopt)

;;; Utility

(define (flatten xs) (if (pair? xs) (append-map flatten xs) (list xs)))

(define (key-map proc list)
  (let1 affect (lambda (k r) (if (keyword? k)
				 (cons (proc k (get-keyword k list)) r)
				 r))
    (reverse (fold affect '() list))))

(define string->keyword (compose make-keyword
				 list->string
				 (cut map char-downcase <>)
				 string->list
				 (cut regexp-replace #/[\s]/ <> "-")))

;;; Metallic Ratio Class

(define-class <metallic-ratio> ()
  ((name :init-value "One" :init-keyword :name :accessor name-of)
   (num  :init-value     0 :init-keyword :num  :accessor num-of)))

(define-method value-of ((ratio <metallic-ratio>))
  (let* ((num (num-of ratio))
	 (root (+ (expt num 2) 4)))
    (/ (+ num (sqrt root))
       2)))

(define-method expr-of ((ratio <metallic-ratio>))
   (let* ((num (num-of ratio))
	  (root (+ (expt num 2) 4)))
     (if (integer? (sqrt root))
	 (let1 num (+ num (sqrt root))
	   (if (even? num)
	       (format "~a" (/ num 2))
	       (format "~a / 2" num)))
	 (if (and (even? num) (even? (/ root 4)))
	     (format "~a + √~a" (/ num 2) (/ root 4))
	     (format "(~a + √~a) / 2" num root)))))

;; Splited Value Class

(define-class <splited-by-rate> ()
  ((rate   :init-value 0 :init-keyword :rate   :accessor rate-of)
   (origin :init-value 0 :init-keyword :origin :accessor origin-of)))

(define-method parent-value-of ((splited <splited-by-rate>))
  (* (origin-of splited) (rate-of splited)))

(define-method larger-value-of ((splited <splited-by-rate>))
  (let ((rate (rate-of splited)))
    (* (origin-of splited) (/ rate (+ 1 rate)))))

(define-method smaller-value-of ((splited <splited-by-rate>))
  (* (origin-of splited) (/ 1 (+ 1 (rate-of splited)))))

(define-method split ((ratio <metallic-ratio>)
		      (value <number>))
  (make <splited-by-rate> :rate (value-of ratio) :origin value))

(define (base-info  value)
  (map (lambda (l)
	 (if (pair? l) (format "[ ~a ] ~a" (car l) (cdr l)) l))
       `(("Value" . ,value)
	 "==========================================")))

(base-info 900)

(define-method info-of-split ((ratio <metallic-ratio>)
			      (value <number>))
  (let1 result (split ratio value)
    (map (lambda (l)
	   (if (pair? l) (format "[ ~a ] ~a" (car l) (cdr l)) l))
	 `((,(name-of ratio) . ,(expr-of ratio))
	   ("Value       " . ,value)
	   ("Rate        " . ,(format #f "1 : ~a" (value-of ratio)))
	   ("Smaller     " . ,(smaller-value-of result))
	   ("Larger      " . ,(larger-value-of result))
	   ("Parent      " . ,(parent-value-of result))
	   "------------------------------------------"))))

(define (make-css attr props)
  (letrec ((properties (key-map (cut format "\t~a: ~a;" <> <>) props)))
    (list #`",|attr| {" properties "}\n")))

(define-method splited-css ((ratio <metallic-ratio>)
			    (value <number>)
			    (border-weight <integer>)
			    (padding <integer>))
  (letrec ((make-attr-name (compose (cut regexp-replace #/-/ <> "_")
				    x->string
				    string->keyword))
	   (floor-int (compose x->integer floor))
	   (splited (split ratio value))
	   (name (make-attr-name (name-of ratio)))
	   (wrapper (- (floor-int (larger-value-of splited))
		       (* border-weight 2)))
	   (larger (- wrapper (* padding 2)))
	   (smaller (- (floor-int (smaller-value-of splited))
		       (+ border-weight
			  (* padding 2)))))
    (list
     "/*"
     (format " * ~a : ~a" (name-of ratio) (expr-of ratio))
     " * =========================================="
     " */"
     (key-map make-css (list
       (make-keyword #`".,|name| .larger")
       (list :float "left"
	     :width #`",|larger|px"
	     :min-height #`",|larger|px"
	     :padding #`",|padding|px"
	     :border-right #`",|border-weight|px solid #ccc")
       (make-keyword #`".,|name| .smaller")
       (list :float "left"
	     :width #`",|smaller|px"
	     :min-height #`",|larger|px"
	     :padding #`",|padding|px")
       (make-keyword #`".,|name| header")  `(:height ,#`",|smaller|px")
       (make-keyword #`".,|name| article") `(:min-height ,#`",|wrapper|px")
       (make-keyword #`".,|name| footer")  `(:height ,#`",|smaller|px"))))))

(define *metallic-ratio-list*
  (flatten
   (let1 num 0
     (map (lambda (name)
	    (list (string->keyword name)
		  (make <metallic-ratio>
		    :name #`",|name| Ratio" :num  (inc! num))))
	  '("Golden" "Silver" "Bronze")))))

(flatten '((1 2) (3 4)))

(define-method base-css ((value <integer>)
			 (border <integer>)
			 (padding <integer>))
  (let1 border-prop  #`",|border|px solid #ccc"
    (list
     "/*"
     #`" * Base Pixel : ,|value|px"
     #`" * Padding : ,|padding|px"
     #`" * Border Stroke Weight : ,|border|px"
     " * ========================================"
     " */"
     (key-map make-css (list
       :html '(:width "100%" :height "100%")
       :body `(:width ,#`",|value|px" :margin "0 auto")
       :header `(:padding ,#`",|padding|px" :border ,border-prop)
       :article (list :clear "both"
		      :border-left border-prop
		      :border-right border-prop)
       :footer (list :clear "both"
		     :padding #`",|padding|px"
		     :border border-prop))))))

;;; Script

(define (usage)
  (format (current-error-port)
	  "Usage: ~a number value to split [Golden Silver Bronze] rate"
	  *program-name*)
  (exit 2))

(define (find-ratio name list)
  (let1 key (string->keyword name)
    (if (member key list)
	(get-keyword key list)
	(begin
	  (format (current-error-port) "Unknown Named Ratio : ~a" name)
	  (exit 2)))))
  
(define (main args)
  (if (null? (cdr args)) (usage)
      (let-args (cdr args)
	  ((css     "c|css")
	   (border  "b|border=i" 0)
	   (padding "p|padding=i" 0)
	   (ratio   "r|ratio=s")
	   (else (opt . _) (print "Unknown option : " opt) (usage))
	   . restargs)
	(if (null? restargs) (usage)
	    (letrec
		((value (x->integer (car restargs)))
		 (make-base (if css
				(base-css value border padding)
				(base-info value)))
		 (make-form (lambda (_ ratio) 
			      (if css
				  (splited-css ratio value border padding)
				  (info-of-split ratio value))))
		 (ratio-list *metallic-ratio-list*)
		 (splits (if ratio
			     (make-form #f (find-ratio ratio ratio-list))
			     (key-map make-form ratio-list)))
		 (result `(,make-base ,splits)))
	      (for-each print (flatten result))
	      0)))))