色づけ、雪をふらせた

とりあえず、色をつけるのと、雪をふらせるオプションをつけてみました

(defun mkstr (list)
    (with-output-to-string (s)
          (dolist (a list)
            (princ a s))))

(defvar foreground-color-list
  '(:black 30
    :red 31
    :green 32
    :yellow 33
    :blue 34
    :magenta 35
    :purple 35
    :cyan 36
    :white 37 
    :default 39))

(defvar background-color-list
  '(:black 40
    :red 41
    :green 42
    :yellow 43
    :blue 44
    :magenta 45
    :purple 45
    :cyan 46
    :white 47
    :default 49))

(defvar reset-code 0)

(defun color-string (str &key (foreground :default) (background :default))
  (format nil "~C[~Am~C[~Am~A~C[~Am"
          #\Esc
          (getf foreground-color-list foreground)
          #\Esc
          (getf background-color-list background)
          str
          #\Esc
          reset-code
          ))

(defun random-atom (list)
  (let ((len (length list)))
    (nth (random len)
         list)))

(defvar ornaments
  '("@" "P" "q" "*" "?" "!"))

(defun tree-line (length &key (fill nil))
  (labels ((%tree-line (acc length)
             (if (zerop length)
               acc
               (%tree-line 
                 (cons (if (zerop (random 4))
                         (color-string (nth (random (length ornaments))
                              ornaments)
                                       :background
                                       (if fill
                                         :green
                                         :default)
                                       :foreground 
                                       (random-atom
                                         '(:green
                                           :blue
                                           :magenta
                                           :cyan
                                           :yellow
                                           :red)))
                         (color-string #\Space
                                       :background
                                       (if fill
                                         :green
                                         :default)))
                       acc)
                 (1- length)))))
    (mkstr (%tree-line nil length))))

(defun air-line (length &key (snow nil))
  (if (not snow)
    (make-string length :initial-element #\Space)
    (labels ((%air-line (acc length)
               (if (zerop length)
                 acc
                 (%air-line 
                   (cons (if (zerop (random 5))
                           (color-string "*"
                                         :foreground
                                         :white)
                           #\Space)
                         acc)
                   (1- length)))))
      (mkstr (%air-line nil length)))))

(defun tree (n &key (fill nil) (snow nil))
  (let ((padding   10))
    ;;Star
    (format t "~A~A~A~%"
            (air-line (+ padding (1- n)) :snow snow)
            (color-string "*" :foreground :yellow
                          :background
                          (if fill
                            :yellow
                            :default))
            (air-line (1- n) :snow snow))
    (format t "~A~A~A~%"
            (air-line (+ -1 padding (1- n)) :snow snow)
            (color-string "***" :foreground :yellow
                          :background
                          (if fill
                            :yellow
                            :default))
            (air-line (- n 2) :snow snow))
    (loop for i from 1 upto n
          do
          (if (= i 1)
            (format t "~A~A~A~%"
                    (air-line (+ padding (1- n)) :snow snow)
                    (color-string "*" :foreground :yellow
                                  :background
                                  (if fill
                                    :yellow
                                    :default))
                    (air-line (1- n) :snow snow))
            (format t "~A~A~A~A~A~%"
                    (air-line (+ padding (- n i)) :snow snow)
                    (color-string "*" :foreground :green
                                  :background
                                  (if fill
                                    :green
                                    :default))
                    (tree-line (1- (* (1- i) 2)) :fill fill)
                    (color-string "*" :foreground :green
                                  :background
                                  (if fill
                                    :green
                                    :default))
                    (air-line (- n i) :snow snow))))
    ;;Tree bottom
    (format t "~A~A~%"
            (make-string (1- padding)
                         :initial-element #\Space)
            (color-string 
              (make-string (1+ (* n 2)) 
                         :initial-element #\*)
              :foreground :green
              :background
              (if fill
                :green
                :default)))
    ;;Tunk of tree
    (dotimes (i 5)
      (format t "~A~A~%"
              (make-string (+ padding n -3)
                           :initial-element #\Space)
              (color-string "******"
                          :foreground :yellow
                          :background
                          (if fill
                            :yellow
                            :default)))))
  (format t "Merry christmas~%"))