Created
December 2, 2011 14:29
-
-
Save valvallow/1423416 to your computer and use it in GitHub Desktop.
christmas tree
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #!/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))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment