Merry Christmas 2017

[john.uhden]

I dug this out of my archives...

It is once again offered with respect to and in celebration of all faiths.  It was just for fun.

WARNING:  Do NOT run this routine on anything but an empty (or disposable) drawing, or QUIT after running.

;;AUTOCAD PROGRAMMING CHALLENGE NO. 2
;;C:XMASTREE
;;John F. Uhden, CADvantage Custom Utilities
;;CADvantage@compuserve.com
;;12-11-97
;;Note (12-08-02):
;;  Jim Fisher recalls better than I the rules of this
;;  programming challenge on the old ACAD Forum.
;;  Technically, this exceeded limitations and should
;;  have been disqualified.  Dietmar Rudolph's was
;;  technically correct and pretty darn nifty.  Too
;;  bad I don't have a copy to share.  In fact, we can
;;  thank Jim for retrieving this from his archives.
;;  Anyway, it's still cute.
;;Revised (12-08-02) for R15+
;;  Added vl-cmdf, UCSICON=0, and SHADE command only.
;;  Try setting SHADEMODE to different values before running,
;;  and then use the 3DORBIT command after.
;;  HAPPY HOLIDAYS!
(defun c:XMASTREE (/ rad R N Z dZ a da d H I J K +- s c)
(setq c (if (>= (getvar "acadver") "15") vl-cmdf command))
(setq d distance s setvar)(s "CMDECHO" 0)(s "UCSICON" 0)
(s "TILEMODE" 1)(s "UCSFOLLOW" 0)(s "HIGHLIGHT" 0)
(s "REGENMODE" 1)(c "_.LINE""0,0""1,1""")(c "_.ZOOM""_E")
(C"_.LAYER""_U""*""")(C"_.ERASE"(ssget"X")"")(c"_.UCS""_W")
(C "_.VPOINT""-3,-3,1.2")(C "_.ZOOM""_C""0,0,7" 15)
(defun rad (Z)(* 0.75 (sqrt (- 12.0 Z))))
(setq N 25 Z 1.0 dZ 0.5 a 0.0 da (/ pi N) hpi (* pi 0.5))
(while (< Z 12.0)(setq R (rad Z))(repeat N
  (setq +- (if (= +- -) + -)
        H (list 0.0 0.0 (+- Z (* dz 0.25)))
        I (polar H a R) a (+ a da)
        I (mapcar '+ I (list 0.0 0.0 (* dZ 0.5)))
        J (polar H a (+ R R)) a (+ a da)
        J (mapcar '+ J (list 0.0 0.0 dZ))
        K (polar H a R)
        K (mapcar '+ K (list 0.0 0.0 (* dZ 0.1))))
  (entmake (list '(0 . "3DFACE")'(62 . 3)'(70 . 0)
  (cons 10 H)(cons 11 I)(cons 12 J)(cons 13 K)))
  (if (and (zerop (rem (1- Z) 1))(zerop (rem N 5)))(progn
    (entmake (list '(0 . "CIRCLE")(cons 10 J)'(40 . 0.07)
   '(39 . 0.35)'(62 . 255)))(prompt " HO")
    (setq J (mapcar '+ J (list 0.0 0.0 0.4)))
    (entmake (list '(0 . "3DFACE")'(62 . 2)'(70 . 0)
    (cons 10 (polar J (+ a hpi)(* (d I K) 0.2)))
    (cons 11 (polar J (- a hpi)(* (d I K) 0.2)))
    (cons 12 (mapcar '+ J (list 0.0 0.0 (* dZ 0.5))))
    (cons 13 (mapcar '+ J (list 0.0 0.0 (* dZ 0.5))))))
  )))(terpri)(setq Z (+ Z dZ) a (+ a (/ da 2))))
(entmake '((0 . "3DFACE")(62 . 7)(10 -0.536 0.57073 13.225)
(11 0.5123 -0.545566 13.225)(12 -0.011815 0.012582 12.6687)
(13 -0.0118153 0.012582 12.6687)(70 . 0)))
(entmake '((0 . "3DFACE")(62 . 7)(10 -0.3357 0.3575 12.325)
(11 -0.0118 0.01258 13.7813) (12 0.18839 -0.200611 12.8812)
(13 0.188387 -0.200611 12.8812) (70 . 0)))
(entmake '((0 . "3DFACE")(62 . 7)(10 -0.536 0.57073 13.225)
(11 0.31212 -0.33237 12.3249) (12 0.111916 -0.11918 13.225)
(13 0.111916 -0.119179 13.225) (70 . 0)))
(c "_.SHADE")(setvar "cmdecho" 1)(alert "\nMerry Christmas!")
(princ))

[Ranjit_Singh]

Very nice @john.uhden. Thanks for sharing and Merry Christmas

[CADaSchtroumpf]

For fun,

An another challenge: a clone of game 2048 by gabriele cirulli in Autolisp

Merry Christmas

Same remark, use in an empty drawing

;; C:GAME2048
;; A clone in AutoLisp of https://gabrielecirulli.github.io/2048/
;; by Bruno VALSECCHI December 2017
;;
;; Join the number and get to the 2048 tile!
;;
;; Play with numeric key pad ( 2 4 6 8 ) for Down Right Left Up
;;
(defun randomize (v1 v2 / )
  (if (not v_sd)
    (setq v_sd (getvar "DATE"))
  )
  (setq v_sd (rem (+ (* 25173 v_sd) 13849) 65536))
  (+ (* (/ v_sd 65536) (- (max v1 v2) (min v1 v2))) (min v1 v2))
)
(defun vl-position-multi (el l / n l_id l_n)
  (setq
    n 0
    l_id (mapcar '(lambda (x) (equal x el)) l)
  )
  (repeat (length l_id)
    (if (car l_id) (setq l_n (cons n l_n)))
    (setq n (1+ n) l_id (cdr l_id))
  )
  (reverse l_n)
)
(defun draw_map (statut_map / lm_col lt_col tmp lx ly dxf_m dxf_t x y)
  (setq lm_col '((0 . 252) (2 . 255) (4 . 53) (8 . 31) (16 . 30) (32 . 20) (64 . 22) (128 . 42) (256 . 52) (512 . 40) (1024 . 32) (2048 . 2)))
  (setq lt_col '((0 . 252) (2 . 250) (4 . 250) (8 . 255) (16 . 255) (32 . 255) (64 . 255) (128 . 255) (256 . 255) (512 . 255) (1024 . 255) (2048 . 1)))
  (setq tmp map)
  (setq lx (mapcar 'car tmp) ly (mapcar 'cdr tmp))
  (foreach dxf_mask lst_mask
    (setq dxf_m (entget (cdr dxf_mask)))
    (mapcar
      '(lambda (xi yi / x y)
        (setq x xi y yi)
        (entmod
          (subst
            (cons 10 (list (cdr x) (car x) 0))
            (assoc 10 dxf_m)
            dxf_m
          )
        )
        (entmod
          (subst
            (cons 11 (list (1+ (cdr x)) (car x) 0))
            (assoc 11 dxf_m)
            dxf_m
          )
        )
        (entmod
          (subst
            (cons 12 (list (cdr x) (1+ (car x)) 0))
            (assoc 12 dxf_m)
            dxf_m
          )
        )
        (entmod
          (subst
            (cons 13 (list (1+ (cdr x)) (1+ (car x)) 0))
            (assoc 13 dxf_m)
            dxf_m
          )
        )
        (entmod
          (subst
            (cons 62 (cdr (assoc y lm_col)))
            (assoc 62 dxf_m)
            dxf_m
          )
        )
      )
      (list (car lx))
      (list (car ly))
    )
    (setq lx (cdr lx) ly (cdr ly))
  )
  (setq lx (mapcar 'car tmp) ly (mapcar 'cdr tmp))
  (foreach dxf_text lst_text
    (setq dxf_t (entget (cdr dxf_text)))
    (mapcar
      '(lambda (x y / x y)
        (entmod
          (subst
            (cons 11 (list (+ 0.5 (cdr x)) (+ 0.5 (car x)) 0))
            (assoc 11 dxf_t)
            dxf_t
          )
        )
        (entmod
          (subst
            (cons 1 (itoa y))
            (assoc 1 dxf_t)
            (subst
              (cons 62 (cdr (assoc y lt_col)))
              (assoc 62 dxf_t)
              dxf_t
            )
          )
        )
      )
      (list (car lx))
      (list (car ly))
    )
    (setq lx (cdr lx) ly (cdr ly))
  )
  (command "_.TEXTTOFRONT" "_Text")
)
(defun evaluate_push (l count / l)
  (setq l (reverse (vl-remove 0 l)))
  (if (cdr l)
    (cond
      ((and (eq (car l) (cadr l)) (<= (+ (car l) (cadr l)) count))
        (evaluate_push (reverse (cons (+ (car l) (cadr l)) (cddr l))) count)
      )
      (T
        (evaluate_push (reverse (cdr l)) count)
        (setq nwl (cons (car l) nwl))
      )
    )
    (setq nwl (cons (car l) nwl))
  )
  (reverse (if (car nwl) nwl '(0)))
)
(defun push (k / lst tmp nwl)
  (setq map-n map)
  (cond
    ((eq k 50)
      (setq lst '("C-U3" "C-U2" "C-U1" "C-U0"))
    )
    ((eq k 52)
      (setq lst '("R-R0" "R-R1" "R-R2" "R-R3"))
    )
    ((eq k 54)
      (setq lst '("R-L3" "R-L2" "R-L1" "R-L0"))
    )
    ((eq k 56)
      (setq lst '("C-D0" "C-D1" "C-D2" "C-D3"))
    )
  )
  (foreach n lst
    (setq tmp (mapcar 'cdr (mapcar '(lambda (x) (assoc x map)) (eval (read n)))) nwl nil)
    (setq nwl (evaluate_push tmp (* (if (member (apply 'max tmp) (cdr (member (apply 'max tmp) tmp))) 2 1) (apply 'max tmp))))
    (if (not (eq (length (vl-remove 0 nwl)) 4))
      (progn
        (repeat (- (length tmp) (length (setq nwl (vl-remove 0 nwl))))
          (setq nwl (cons 0 nwl))
        )
        nwl
      )
      nwl
    )
    (setq tmp (mapcar '(lambda (x) (assoc x map)) (eval (read n))))
    (foreach n (mapcar '(lambda (x y) (cons x y)) (mapcar 'car (mapcar '(lambda (x) (assoc x map)) (eval (read n)))) nwl)
      (setq map (subst n (assoc (car n) map) map))
    )
  )
)
(defun c:Game2048 ( / v_sd mat_game map lst_mask lst_text nw_pos key before after win loose)
  (foreach n '("R-L0" "R-L1" "R-L2" "R-L3" "R-R0" "R-R1" "R-R2" "R-R3") (set (read n) nil))
  (foreach n '("C-U0" "C-U1" "C-U2" "C-U3" "C-D0" "C-D1" "C-D2" "C-D3") (set (read n) nil))
  (setq mat_game
    '(
      (3 . 0) (3 . 1) (3 . 2) (3 . 3)
      (2 . 0) (2 . 1) (2 . 2) (2 . 3)
      (1 . 0) (1 . 1) (1 . 2) (1 . 3)
      (0 . 0) (0 . 1) (0 . 2) (0 . 3)
    )
  )
  (mapcar
    '(lambda (x y)
      (set
        (read (strcat "R-R" (itoa y)))
        (reverse x)
      )
    )
    (mapcar
      '(lambda (x y)
        (foreach n x
          (set
            (read (strcat "R-L" (itoa y)))
            (cons
              (nth n mat_game)
              (eval (read (strcat "R-L" (itoa y))))
            )
          )
        )
      )
      (mapcar
        '(lambda (x)
          (vl-position-multi x (mapcar 'car mat_game))
        )
        '(0 1 2 3)
      )
      '(0 1 2 3)
    )
    '(0 1 2 3)
  )
  (mapcar
    '(lambda (x y)
      (set
        (read (strcat "C-D" (itoa y)))
        (reverse x)
      )
    )
    (mapcar
      '(lambda (x y)
        (foreach n x
          (set
            (read (strcat "C-U" (itoa y)))
            (cons
              (nth n mat_game)
              (eval (read (strcat "C-U" (itoa y))))
            )
          )
        )
      )
      (mapcar
        '(lambda (x)
          (vl-position-multi x (mapcar 'cdr mat_game))
        )
        '(0 1 2 3)
      )
      '(0 1 2 3)
    )
    '(0 1 2 3)
  )
  (setq map (mapcar '(lambda (n / ) (cons n 0)) mat_game))
  (entmake
    '(
      (0 . "STYLE")
      (100 . "AcDbSymbolTableRecord")
      (100 . "AcDbTextStyleTableRecord")
      (2 . "2048")
      (70 . 0)
      (40 . 0.0)
      (41 . 1.0)
      (50 . 0.0)
      (71 . 0)
      (42 . 0.5)
      (3 . "arial.ttf")
      (4 . "")
    )
  )
  (setvar "TEXTSTYLE" "2048")
  (setvar "CMDECHO" 0)
  (command "_.zoom" "_window" "_none" '(0 0) "_none" '(4 4))
  (foreach n map
    (entmake
      (list
        '(0 . "SOLID")
        '(100 . "AcDbEntity")
        '(67 . 0)
        '(410 . "Model")
        '(8 . "0")
        '(62 . 252)
        '(100 . "AcDbTrace")
        (cons 10 (list (cdar n) (caar n) 0))
        (cons 11 (list (1+ (cdar n)) (caar n) 0))
        (cons 12 (list (cdar n) (1+ (caar n)) 0))
        (cons 13 (list (1+ (cdar n)) (1+ (caar n)) 0))
        '(39 . 0.0)
        '(210 0.0 0.0 1.0)
      )
    )
    (setq lst_mask (cons (assoc -1 (entget (entlast))) lst_mask))
    (entmake
      (list
        '(0 . "TEXT")
        '(100 . "AcDbEntity")
        '(67 . 0)
        '(410 . "Model")
        '(8 . "0")
        '(62 . 252)
        '(100 . "AcDbText")
        (cons 10 (list (+ (cdar n) 0.19423602) (+ (caar n) 0.25) 0))
        '(40 . 0.5)
        '(1 . "0")
        '(50 . 0.0)
        '(41 . 0.65)
        '(51 . 0.0)
        '(7 . "2048")
        '(71 . 0)
        '(72 . 1)
        (cons 11 (list (+ (cdar n) 0.5) (+ (caar n) 0.5) 0))
        '(210 0.0 0.0 1.0)
        '(100 . "AcDbText")
        '(73 . 2)
      )
    )
    (setq lst_text (cons (assoc -1 (entget (entlast))) lst_text))
  )
  (setq nw_pos
    (cons
      (cons
        (read (rtos (randomize 0 3) 2 0))
        (read (rtos (randomize 0 3) 2 0))
      )
      (* 2 (read (rtos (randomize 1 2) 2 0)))
    )
  )
  (if
    (or
      (zerop (cdr (assoc (car nw_pos) map)))
      (eq (cdr (assoc (car nw_pos) map)) (cdr nw_pos))
    )
    (setq map (subst (cons (car nw_pos) (+ (cdr nw_pos) (cdr (assoc (car nw_pos) map)))) (assoc (car nw_pos) map) map))
  )
  (draw_map map)
  (print)
  (while (and (setq key (grread T 4 0)) (not loose))
    (if (member (cadr key) '(50 52 54 56))
      (progn
        (setq before (mapcar 'cdr map))
        (push (cadr key))
        (if (member 2048 (mapcar 'cdr map)) (progn (setq win T) (alert "WIN")))
        (setq after (mapcar 'cdr map))
        (cond
          ((not (equal before after))
            (while
              (not
                (zerop
                  (cdr
                    (assoc
                      (car
                        (setq nw_pos
                          (cons
                            (cons
                              (read (rtos (randomize 0 3) 2 0))
                              (read (rtos (randomize 0 3) 2 0))
                            )
                            (* 2 (read (rtos (randomize 1 2) 2 0)))
                          )
                        )
                      )
                      map
                    )
                  )
                )
              )
            )
            (if
              (or
                (zerop (cdr (assoc (car nw_pos) map)))
                (eq (cdr (assoc (car nw_pos) map)) (cdr nw_pos))
              )
              (setq map (subst (cons (car nw_pos) (+ (cdr nw_pos) (cdr (assoc (car nw_pos) map)))) (assoc (car nw_pos) map) map))
            )
            (draw_map map)
          )
          (T (if (not (member 0 (mapcar 'cdr map))) (setq loose T)))
        )
      )
    )
  )
  (if (not win) (alert "LOSE"))
  (command "_.ERASE" "_All" "")
  (setvar "TEXTSTYLE" "Standard")
  (setvar "CMDECHO" 1)
  (foreach n '("R-L0" "R-L1" "R-L2" "R-L3" "R-R0" "R-R1" "R-R2" "R-R3") (set (read n) nil))
  (foreach n '("C-U0" "C-U1" "C-U2" "C-U3" "C-D0" "C-D1" "C-D2" "C-D3") (set (read n) nil))
  (prin1)
)

[john.uhden]

It is a shame I couldn't enjoy it.  My AutoCAD 2002 doesn't have a TEXTTOFRONT command.

Have a Merry Christmas anyway, OR ELSE!

[CADaSchtroumpf]

Hi John

With 2002 try to change in function (draw_map

  (foreach dxf_text lst_text
.....
....
    )
    (setq lx (cdr lx) ly (cdr ly))
  )
  (command "_.TEXTTOFRONT" "_Text")

by

  (foreach dxf_text lst_text
....
....
    )
    (command "_DRAWORDER" (cdr dxf_text) "" "_Front")
    (setq lx (cdr lx) ly (cdr ly))
  )
  ;(command "_.TEXTTOFRONT" "_Text")

[john.uhden]

Well, I got 1 2 3 4 in nicely shaded rectangles.  Thanks!

I'll have to take a more serious look at it maybe tomorrow.

1 2 3 4 reminds me of something  silly from years ago.

;; Digital.LSP (01-07-2002), John F. Uhden, Cadlantic
;; Dedicated to David Bethel
;; Does not look good with rotated UCSs or ViewTwists
;; Add your own character functions as needed.
(defun digital (midp str height color / p i fun bar #0 #1 #2 #3 #4 #5 #6 #7 #8 #9)
   (defun bar (p height color dir / ph n t- t+ b- b+ d++ d+-)
      (setq p  (list (car p)(cadr p))
            height (* height 0.5)
            ph     (/ (getvar "viewsize")(cadr (getvar "screensize"))) ; pixel height
            n      (max 1 (fix (/ height 6 ph)))
            height (- height (* ph (sqrt n)))
      )
      (if (= dir "UP")
         (setq t-  (mapcar '+ p (list 0.0 height))
               b-  (mapcar '- p (list 0.0 height))
               d++ (list ph ph)
               d+- (list ph (- ph))
         )
         (setq t-  (mapcar '+ p (list height 0.0))
               b-  (mapcar '- p (list height 0.0))
               d+- (list (- ph)(- ph))
               d++ (list ph (- ph))
         )
      )
      (setq t+ t- b+ b-)
      (grvecs (list color t- b-))
      (repeat n
         (grvecs
            (list
               color
               (setq t- (mapcar '- t- d++))
               (setq b- (mapcar '- b- d+-))
            )
         )
         (grvecs
            (list
               color
               (setq t+ (mapcar '+ t+ d+-))
               (setq b+ (mapcar '+ b+ d++))
            )
         )
      )
   )
   (defun #0 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
      (bar (mapcar '+ midp (list (- 1/4h)(- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list (- 1/4h) 1/4h)) 1/2h color "UP")
   )
   (defun #1 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar (mapcar '+ midp (list 0.0 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/4h))) 1/2h color "UP")
   )
   (defun #2 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
      (bar (mapcar '+ midp (list (- 1/4h)(- 1/4h))) 1/2h color "UP")
   )
   (defun #3 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
   )
   (defun #4 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list (- 1/4h) 1/4h)) 1/2h color "UP")
   )
   (defun #5 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
      (bar (mapcar '+ midp (list (- 1/4h) 1/4h)) 1/2h color "UP")
   )
   (defun #6 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
      (bar (mapcar '+ midp (list (- 1/4h)(- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list (- 1/4h) 1/4h)) 1/2h color "UP")
   )
   (defun #7 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
   )
   (defun #8 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
      (bar (mapcar '+ midp (list (- 1/4h)(- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list (- 1/4h) 1/4h)) 1/2h color "UP")
   )
   (defun #9 (midp height color / h 1/4h 1/2h)
      (setq 1/2h (* height 0.5)
            1/4h (* height 0.25)
            midp (list (car midp)(cadr midp))
      )
      (bar midp 1/2h color nil)
      (bar (mapcar '+ midp (list 0.0 1/2h)) 1/2h color nil)
      (bar (mapcar '+ midp (list 1/4h 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 1/4h (- 1/4h))) 1/2h color "UP")
      (bar (mapcar '+ midp (list (- 1/4h) 1/4h)) 1/2h color "UP")
      (bar (mapcar '+ midp (list 0.0 (- 1/2h))) 1/2h color nil)
   )
   (setq midp (list (car midp)(cadr midp))
         p (polar midp pi (* height 0.4 (1- (strlen str))))
         i 1
   )
   (repeat (strlen str)
      (if (eval (setq fun (read (strcat "#" (substr str i 1)))))
         (eval (list fun (quote p) height color))
      )
      (setq p (polar p 0.0 (* height 0.8))
            i (1+ i)
      )
   )
)

(defun digicount ( / n p h i)
   (setq n 999
         p (getvar "viewctr")
         h (/ (getvar "viewsize") 6)
   )
   (while (<= n 2000)
      (setq n (1+ n))
      (digital p (rtos n 2 0) h 3)
      (princ)
      (digital p (rtos n 2 0) h 0)
   )
   (digital p (rtos n 2 0) h 3)
)

In 2002 my screen went white.  I dunno, maybe I should have been using leaded gas.