card.lisp

(defconstant character-patterns
  (quote ((#\Newline . #*000000000000)
          (#\Space . #*000000000000)
          (#\0 . #*001000000000)
          (#\1 . #*000100000000)
          (#\2 . #*000010000000)
          (#\3 . #*000001000000)
          (#\4 . #*000000100000)
          (#\5 . #*000000010000)
          (#\6 . #*000000001000)
          (#\7 . #*000000000100)
          (#\8 . #*000000000010)
          (#\9 . #*000000000001)
          (#\= . #*000000001010)
          (#\" . #*000000000110)
          (#\+ . #*100000001010)
          (#\A . #*100100000000)
          (#\B . #*100010000000)
          (#\C . #*100001000000)
          (#\D . #*100000100000)
          (#\E . #*100000010000)
          (#\F . #*100000001000)
          (#\G . #*100000000100)
          (#\H . #*100000000010)
          (#\I . #*100000000001)
          (#\. . #*100001000010)
          (#\) . #*010000010010)
          (#\- . #*010000000000)
          (#\J . #*010100000000)
          (#\K . #*010010000000)
          (#\L . #*010001000000)
          (#\M . #*010000100000)
          (#\N . #*010000010000)
          (#\O . #*010000001000)
          (#\P . #*010000000100)
          (#\Q . #*010000000010)
          (#\R . #*010000000001)
          (#\* . #*010000100010)
          (#\/ . #*001100000000)
          (#\S . #*001010000000)
          (#\T . #*001001000000)
          (#\U . #*001000100000)
          (#\V . #*001000010000)
          (#\W . #*001000001000)
          (#\X . #*001000000100)
          (#\Y . #*001000000010)
          (#\Z . #*001000000001)
          (#\, . #*001001000010)
          (#\$ . #*010001000010)
          (#\( . #*100000010010))))

(defvar character-table (make-hash-table :test 'equalp))

(mapcar (lambda (c)
          (setf (gethash (car c) character-table) (cdr c)))
        character-patterns)

(defun n-characters (n character)
  (make-string n :initial-element character))

(defun string->card-string (string &optional (card-width 72) (punched #\*))
  (let* ((string (string-right-trim '(#\Space #\Tab) string))
         (length (length string)))
    (with-output-to-string (out)
      (format out " ~A~%/~:@(~A~)~@?|~%" (n-characters card-width #\_)
                                         string
                                         (format nil "~~~D,0T" (+ card-width 1)))
      (loop for r from 0 below 12 do
        (write-char #\| out)
        (loop for i from 0 below card-width do
          (let ((blank (if (< r 2)
                           #\Space
                           (digit-char (- r 2))))
                (c (if (>= i length)
                       0
                       (sbit (gethash (char string i) character-table) r))))
            (write-char (if (not (zerop c))
                            punched
                            blank)
                        out)))
        (write-char #\| out)
        (terpri out))
      (format out "|~A|~%" (n-characters card-width #\_)))))