#!/usr/local/bin/gosh (use srfi-1) (use util.match) (use gauche.parseopt) ;;; ;;; - christmas tree ;;; http://parametron.blogspot.com/2010/12/blog-post.html ;;; - ansi coloring ;;; http://d.hatena.ne.jp/trotr/20091031/1257001416 ;;; (define (usage) (print "Usage: christmas-tree [options ...]") (print " - s|size : tree size (default 5)") (print " - c|color : coloring tree (ansi)") (print " - h|help : print usage") (exit 2)) ;; main algorithm (define (make-christmas-tree size) (define (next tree) (filter (pa$ (complement null?)) (append-map (^l (let ((ss0 (map (cut append <> (list #f)) l)) (ss1 (map (cut append <> (list #t)) l))) (let ((ss1 (cons (car ss0) ss1)) (ss0 (cdr ss0))) (list ss0 ss1)))) tree))) (let rec ((n (- size 1))(tree '(((#f)(#t))))) (if (<= n 0) tree (rec (- n 1)(next tree))))) (define (tree-leaf-> tchar fchar tree) (map (map$ (.$ list->string (map$ (^e (if e tchar fchar))))) tree)) ;; ;; coloring ;; (define (field->ansi-color-escape row) (define (string->ansi-escape str num) (apply string-append (map (apply$ string) (list `(#\escape #\[ ,@(string->list (x->string num)) #\m) (string->list str) `(#\escape #\[ ,@'(#\0) #\m))))) (define (string->num-list str) (map (.$ x->integer string)(string->list str))) (define (escape prev cur next) (apply string-append (map (^ (p c n) (match (list p c n) ((_ 0 1)(string->ansi-escape (string->ansi-escape (x->string c) 31) 1)) ((0 1 _)(string->ansi-escape (string->ansi-escape (x->string c) 36) 1)) (else (string->ansi-escape (x->string c) 32)))) (string->num-list (if prev prev (make-string (string-length cur)))) (string->num-list cur) (string->num-list (if next next (make-string (string-length cur))))))) ;; body (let rec ((rest row)(prev #f)(acc '())) (if (null? rest) (reverse acc) (let1 escaped (escape prev (car rest)(and (not (null? (cdr rest))) (cadr rest))) (rec (cdr rest)(car rest) (cons escaped acc)))))) (define (print-christmas-tree tree :optional (color #f)) (define (print-field row) (for-each (^f (display f) (display " ")) row) (newline)) (define (fill-field n fill row) (let rec ((n n)(acc row)) (if (zero? n) acc (rec (- n 1)(cons fill acc))))) ;; body (let* ((field-width (length (caar tree))) (max-field-count (apply max (map length tree))) (empty-field (make-string field-width #\space))) (let1 tree (tree-leaf-> #\1 #\0 tree) (for-each (^r (let* ((row (if color (field->ansi-color-escape r) r)) (lacks (quotient (- max-field-count (length row)) 2)) (row (fill-field lacks empty-field row))) (print-field row))) tree)))) (define (main args) (let-args (cdr args) ((size "s|size=i" 6) (color "c|color") (help "h|help" => usage) (else (opt . _) (print "Unknown option : " opt) (usage)) . rest) (print-christmas-tree (make-christmas-tree size) color)))