;;; ---------------------------------------------------------------------------
;;; TestCard.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; DISPLAY TEST CARD AND TIMING BENCHMARK
;;;
;;; PURPOSE
;;;   Draws a test card - the drafting equivalent of the old broadcast test
;;;   pattern - and times how long AutoCAD takes to build, regenerate and redraw
;;;   it. Use it to compare machines, graphics cards, display drivers and
;;;   hardware acceleration settings, or to check that a colour scheme is legible
;;;   before committing a whole office to it.
;;;
;;; WHAT IS ON THE CARD
;;;   Colour wheel      One wedge per colour, so you can see at a glance which
;;;                     colours are distinguishable on this screen and which two
;;;                     look identical. This is the part worth having.
;;;   Convergence grid  Nested right angles at eight decreasing spacings, from
;;;                     0.200 down to 0.025. The spacing at which the arms stop
;;;                     resolving into separate lines is the useful number.
;;;   Diagonal fan      Thirty-seven lines converging on one point at ever
;;;                     shallower angles - shows up aliasing and line snapping.
;;;   Arc nest          Nineteen concentric semicircles, closing up as they go
;;;                     in, for the same test on curves.
;;;   Registration      Corner brackets at the wheel's four extremes.
;;;   Timings           Build, regen and redraw, in seconds.
;;;
;;; SIZE
;;;   The card is 11 x 8.5 drawing units, so it fits a landscape letter sheet at
;;;   1:1. It is drawn from a point you pick, so it can go in an empty corner of
;;;   a real drawing without disturbing anything.
;;;
;;; WHAT WAS FIXED
;;;   - The original created one LAYER PER COLOUR, named "1" to "N", and left
;;;     them all behind. Everything now goes on a single layer called TestCard
;;;     with the colour set on each object, which tests exactly the same thing
;;;     and purges in one step.
;;;   - It created a text style called "crtest" and left that behind too. The
;;;     current style is used instead.
;;;   - It set EXPERT to 1 and never put it back, which suppresses the "are you
;;;     sure" prompts across the whole session.
;;;   - Its last instruction was (command "save" ""), so running a benchmark
;;;     overwrote whatever drawing you had open.
;;;   - It changed LIMITS and zoomed to extents without restoring the view.
;;;   - Two source lines were corrupted, each with a stray byte where the line
;;;     break should have been, merging two statements into one.
;;;   - Angles were written as typed-in decimals - 1.5707963 for a right angle
;;;     and 0.7853984 for half of one, the latter wrong in the seventh place.
;;;     They are computed from PI now.
;;;
;;;   TESTCARD  - draw the card and report the timings
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; DRAWING HELPERS
;;;
;;; Objects are built with ENTMAKE rather than by driving the LINE and TEXT
;;; commands. It is faster, it cannot be upset by a running object snap or a
;;; different command-prompt sequence between releases, and the colour goes on
;;; the object directly instead of by switching layers forty times.
;;; ---------------------------------------------------------------------------

(setq TestCard:LAYER "TestCard")

(defun TestCard:Line ( p1 p2 col )
    (entmake (list '(0 . "LINE") (cons 8 TestCard:LAYER) (cons 62 col)
                   (cons 10 p1) (cons 11 p2)))
)

(defun TestCard:Arc ( cen rad a1 a2 col )
    (entmake (list '(0 . "ARC") (cons 8 TestCard:LAYER) (cons 62 col)
                   (cons 10 cen) (cons 40 rad) (cons 50 a1) (cons 51 a2)))
)

;;; A triangular SOLID. Groups 12 and 13 are the same point, which is how a
;;; four-cornered solid is made to have three corners.
(defun TestCard:Wedge ( p1 p2 p3 col )
    (entmake (list '(0 . "SOLID") (cons 8 TestCard:LAYER) (cons 62 col)
                   (cons 10 p1) (cons 11 p2) (cons 12 p3) (cons 13 p3)))
)

;;; Text. JUST is 0 left, 1 centred, 2 right. When it is not left, group 11 has
;;; to carry the alignment point as well as group 10.
(defun TestCard:Text ( pt hgt txt col just )
    (entmake (append
        (list '(0 . "TEXT") (cons 8 TestCard:LAYER) (cons 62 col)
              (cons 10 pt) (cons 40 hgt) (cons 1 txt) '(50 . 0.0))
        (if (zerop just) nil (list (cons 72 just) (cons 11 pt)))))
)

;;; ---------------------------------------------------------------------------
;;; THE PATTERNS
;;;
;;; Every one takes ORG, the bottom left corner of the card, and works in
;;; card coordinates from there.
;;; ---------------------------------------------------------------------------

(defun TestCard:P ( org x y ) (list (+ (car org) x) (+ (cadr org) y) 0.0))

;;; The colour wheel: NUM wedges sweeping the top half of a circle, coloured 1
;;; upwards. Two wedges that look the same are two colours this display cannot
;;; tell apart.
(defun TestCard:ColourWheel ( cen num / step a1 a2 i )
    (setq step (/ pi (float num)) a1 pi i 1)
    (repeat num
        (setq a2 (+ a1 step))
        (TestCard:Wedge (polar cen a1 2.0) (polar cen a2 2.0) cen i)
        (setq a1 a2 i (1+ i)))
)

;;; Convergence grid: eight rows of nested right angles, each row a finer
;;; spacing than the last, labelled with the spacing used.
(defun TestCard:Convergence ( org / base oset corner up diag )
    (setq base (TestCard:P org 0.25 0.25)
          oset 0.225
          up   (/ pi 2.0)
          diag (/ pi 4.0))
    (repeat 8
        (setq oset (- oset 0.025) corner base)
        (repeat 5
            (TestCard:Line (polar corner up (* oset 4.0)) corner 4)
            (TestCard:Line corner (polar corner 0.0 (* oset 4.0)) 4)
            (setq corner (polar corner diag oset)))
        (setq corner (polar corner diag (* oset 2.0)))
        (TestCard:Text corner (* oset 2.0) (rtos oset 2 3) 7 0)
        (setq base (polar base up (* oset 8.0))))
)

;;; Diagonal fan: lines from a rising point to one fixed point, the rise getting
;;; smaller each time so the angles crowd together at the top.
(defun TestCard:Diagonals ( org / corner target oset up )
    (setq corner (TestCard:P org 10.75 0.25)
          target (TestCard:P org 8.0 2.5)
          oset   0.38
          up     (/ pi 2.0))
    (repeat 37
        (setq oset (- oset 0.01))
        (TestCard:Line corner target 4)
        (setq corner (polar corner up oset)))
)

;;; Arc nest: concentric semicircles closing in on the centre, the gap between
;;; them shrinking as they go.
(defun TestCard:Arcs ( cen / rad oset )
    (setq rad 2.0 oset 0.20)
    (repeat 19
        (setq oset (- oset 0.01))
        (TestCard:Arc cen rad 0.0 pi 7)
        (setq rad (- rad oset)))
)

;;; Registration brackets at the four extremes of the wheel.
(defun TestCard:Registration ( cen / up )
    (setq up (/ pi 2.0))
    (foreach a (list up 0.0 pi (+ pi up))
        (TestCard:Line (polar (polar cen a 2.0) (+ a up) 1.0)
                       (polar (polar (polar cen a 2.0) (+ a up) 1.0)
                              (+ a up pi) 2.0)
                       1))
)

;;; ---------------------------------------------------------------------------
;;; MAIN COMMAND
;;; ---------------------------------------------------------------------------

(defun c:TESTCARD ( / *error* vars vals org num sys disp note cen
                      d1 d2 d3 d4 tBuild tRegen tRedraw v )

    (setq vars '("CMDECHO" "BLIPMODE" "CLAYER" "OSMODE" "TEXTSTYLE")
          vals (mapcar 'getvar vars))

    (defun TestCard:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End"))
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        (princ)
    )

    (defun *error* ( msg )
        (TestCard:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** TESTCARD error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    (setvar "OSMODE" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (princ "\nDisplay test card. It draws 11 x 8.5 units from the point you pick,")
    (princ "\nall on one layer called TestCard, and reports the timings.")

    (initget 6)
    (setq num (getint "\nHow many colours to test <7>: "))
    (if (null num) (setq num 7))
    (if (> num 255) (setq num 255))

    (setq sys  (getstring t "\nMachine, or press Enter to leave blank: ")
          disp (getstring t "\nDisplay or graphics card: ")
          note (getstring t "\nAny note about this test: "))

    (setq org (getpoint "\nBottom left corner of the card: "))

    (if (null org)
        (princ "\nCancelled.")
        (progn
            (setq org (list (car org) (cadr org) 0.0)
                  cen (TestCard:P org 5.5 4.25))

            ;; One layer, made if it is not already there, and left unfrozen and
            ;; on so the card is actually visible when it is finished.
            (command "_.LAYER" "_Make" TestCard:LAYER "_Color" "7" TestCard:LAYER
                     "_On" TestCard:LAYER "_Thaw" TestCard:LAYER "")

            (setq d1 (getvar "DATE"))

            (princ "\n  Border and colour wheel...")
            (TestCard:Line (TestCard:P org 0.0  0.0) (TestCard:P org 11.0 0.0) 7)
            (TestCard:Line (TestCard:P org 11.0 0.0) (TestCard:P org 11.0 8.5) 7)
            (TestCard:Line (TestCard:P org 11.0 8.5) (TestCard:P org 0.0  8.5) 7)
            (TestCard:Line (TestCard:P org 0.0  8.5) (TestCard:P org 0.0  0.0) 7)
            (TestCard:ColourWheel cen num)

            (princ "\n  Convergence grid...")
            (TestCard:Convergence org)

            (princ "\n  Diagonal fan...")
            (TestCard:Diagonals org)

            (princ "\n  Arc nest...")
            (TestCard:Arcs cen)
            (TestCard:Registration cen)

            (princ "\n  Labels...")
            (TestCard:Text (TestCard:P org 5.5 7.8) 0.28 "Display Test Card" 7 1)
            (if (/= "" sys)
                (TestCard:Text (TestCard:P org 5.5 7.3) 0.25 sys 1 1))
            (if (/= "" disp)
                (TestCard:Text (TestCard:P org 5.5 6.9) 0.25 disp 2 1))
            (if (/= "" note)
                (TestCard:Text (TestCard:P org 5.5 6.5) 0.25 note 3 1))

            (TestCard:Text (TestCard:P org 5.5 1.7) 0.2 "Build time:"  3 2)
            (TestCard:Text (TestCard:P org 5.5 1.4) 0.2 "Regen time:"  3 2)
            (TestCard:Text (TestCard:P org 5.5 1.1) 0.2 "Redraw time:" 3 2)
            (TestCard:Text (TestCard:P org 5.5 0.5) 0.2
                (strcat (itoa num) " colours") 7 1)

            ;; --- the three timings ------------------------------------------
            ;; DATE is a Julian day number, so a difference in days multiplied by
            ;; the seconds in a day gives seconds.
            (setq d2 (getvar "DATE"))
            (princ "\n  Timing regen...")
            (command "_.REGEN")
            (setq d3 (getvar "DATE"))
            (princ "\n  Timing redraw...")
            (command "_.REDRAW")
            (setq d4 (getvar "DATE"))

            (setq tBuild  (* 86400.0 (- d2 d1))
                  tRegen  (* 86400.0 (- d3 d2))
                  tRedraw (* 86400.0 (- d4 d3)))

            (TestCard:Text (TestCard:P org 5.6 1.7) 0.2
                (strcat (rtos tBuild 2 3) " sec") 3 0)
            (TestCard:Text (TestCard:P org 5.6 1.4) 0.2
                (strcat (rtos tRegen 2 3) " sec") 3 0)
            (TestCard:Text (TestCard:P org 5.6 1.1) 0.2
                (strcat (rtos tRedraw 2 3) " sec") 3 0)

            (princ (strcat "\n\nBuild  " (rtos tBuild 2 3) " sec"
                           "\nRegen  " (rtos tRegen 2 3) " sec"
                           "\nRedraw " (rtos tRedraw 2 3) " sec"))

            (initget "Yes No")
            (setq v (getkword "\n\nZoom to the card [Yes/No] <Yes>: "))
            (if (/= "No" v)
                (command "_.ZOOM" "_Window"
                         (TestCard:P org -0.5 -0.5) (TestCard:P org 11.5 9.0)))

            (princ "\nEverything is on layer TestCard - erase or purge it when done.")
        )
    )

    (TestCard:Restore)
    (princ)
)

(princ)