;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

;;;Date: Sun 8 Sep 85 00:45-EDT
;;;From: Gail Zacharias <GZ%MIT-OZ@MIT-MC.ARPA>
;;;Subject: Am I bored yet?
;;;To: bandykin%MIT-OZ@MIT-MC.ARPA

;; Load this into your RUTGERS Common Lisp (tm) and do
;;   (setq *print-case* :studly)

(defun studly-output-object (object &optional (level 0))
  (if (eq *print-case* :studly)
      (cond ((symbolp object)
             (studly-output-symbol object))
            ((consp object)
             (studly-output-cons object level))
            (t (let ((*print-case* :upcase))
		 (wimpy-output-object object level))))
    (wimpy-output-object object level)))

(defun studly-output-cons (object level)
  (if (and *print-level* (<= *print-level* level)) (write-char #\#)
    (do ((length 0 (1+ length)) (obj object (cdr obj)) (ch #\( #\space))
	 ((atom obj)
	  (when obj (write-string " . ") (studly-output-object obj (1+ level)))
	  (write-char #\)))
	(write-char ch)
      (unless (or (null *print-length*) (> *print-length* length))
	(write-string "... )")
	(return nil))
      (studly-output-object (car obj) (1+ level))))
  object)

(defun studly-output-symbol (symbol)
  (write-string (studlivify-symbol-name (write-to-string symbol :case :upcase)))
  symbol)

(defun studlivify-symbol-name (name)
  (do ((start 0 (1+ start)) (length (length (the string name)))
       (c) (qflag nil) (h) (end))
      ((>= start length) name)
    (setq c (schar name start))
    (cond ((and *print-escape* (char= c #\|)) (setq qflag (not qflag)))
          (t (when (and *print-escape* (char= c #\\))
	       (setq c (schar name (setq start (1+ start)))))
	     (when (alphanumericp c)
	       (setq h (char-code c))
	       (setq end (do ((i (1+ start) (1+ i))) ((>= i length) length)
			   (setq c (schar name i))
			   (unless (and *print-escape* (char= c #\|))
	   (when (and *print-escape* (char= c #\\))
	     (setq c (schar name (setq i (1+ i)))))
	   (when (not (alphanumericp c)) (return i))
	   (setq h (+ h (char-code c))))))
  (do ((i start (1+ i)))
      ((>= i end))
    (setq c (schar name i))
    (cond ((and *print-escape* (char= c #\|))
			(setq qflag (not qflag)))
		       ((and *print-escape* (char= c #\\))
			(setq i (1+ i)))
		       ((and (not qflag) (upper-case-p c)
			     (= 0 (logand 3 (- h (char-code c)))))
			(setf (char name i) (char-downcase c)))))
	       (setq start end)))))) 

(defun stud ()
  (unless (fboundp 'wimpy-output-object)
    (setf (symbol-function 'wimpy-output-object)
          (symbol-function 'lisp::output-object)))
  (setf (symbol-function 'lisp::output-object)
        (symbol-function 'studly-output-object))) 

(defun wimp ()
  (unless (fboundp 'wimpy-output-object)
    (error "~S ~S ~S" 'yes 'you 'are))
  (setq *print-case* :upcase)
  (setf (symbol-function 'lisp::output-object)
        (symbol-function 'wimpy-output-object)))

;(eval-when (eval load) (stud))