Skip to content

Instantly share code, notes, and snippets.

@valvallow
Created December 2, 2011 14:29
  • Star 1 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save valvallow/1423416 to your computer and use it in GitHub Desktop.
christmas tree
#!/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