;;;-*- Mode: Lisp; Package: COMMON-LISP-USER -*-
;;----------------------------------------------------------------------
;; 
;; Copyright:   Copyright (c) 1998 John Wiseman
;; File:        cgr.lisp
;; Created:     22 September 1997
;; Author:      John Wiseman
;; 
;; Description: Chaos Game Representation stuff (with graphics for
;;              Macintosh Common Lisp).
;; 
;; Changes:     
;; 
;;----------------------------------------------------------------------

(require :quickdraw)


(defclass cgr ()
  ((cgr-characters :accessor cgr-characters :initform '() :initarg :characters)
   (x :accessor cgr-x :initform 0 :initarg :x)
   (y :accessor cgr-y :initform 0 :initarg :y)))


(defmethod initialize-instance :around ((self cgr) &key)
  (call-next-method)
  (setf (cgr-characters self) (compute-cgr-characters self)))

(defmethod reset-cgr ((self cgr))
  (setf (cgr-x self) 0)
  (setf (cgr-y self) 0)
  self)

(defmethod advance-cgr ((self cgr) char)
  (multiple-value-bind (new-x new-y)
                       (character-position self char)
    (setf (cgr-x self) (/ (+ (cgr-x self) new-x) 2))
    (setf (cgr-y self) (/ (+ (cgr-y self) new-y) 2)))
  self)

(defmethod cgr-char-circle ((self cgr) view)
  (let* ((r (view-radius view))
         (ro (+ r 1))
         (rp (+ r 9))
         (origin (view-center view)))
    (with-focused-view view
      (frame-oval view
                  (- (point-h origin) ro)
                  (- (point-v origin) ro)
                  (+ (point-h origin) ro)
                  (+ (point-v origin) ro))
      (dolist (char (cgr-characters self))
        (multiple-value-bind (x y)
                             (character-position self char)
          (move-to view
                   (- (round (+ (point-h origin) (* rp x))) 2)
                   (+ (round (+ (point-v origin) (* rp y))) 2)))
        (with-pstrs ((s (format nil "~A" char)))
          (#_drawstring s))))))







(defclass text-cgr (cgr)
  ())

(defmethod compute-cgr-characters ((self text-cgr))
  (let ((l '()))
    (dotimes (i 95 (nreverse l))
      (push (code-char (+ i 32)) l))))

(defmethod char-index ((self text-cgr) char)
  (- (char-code char) 32))

(defmethod char-valid-p ((self text-cgr) char)
  (declare (ignore self))
  (let ((code (char-code char)))
    (and (>= code 32) (<= code 126))))

(defmethod character-angle ((self text-cgr) char)
  (let ((index (char-index self char)))
    (+ (* #.(/ pi 2) index)
       (* #.(* pi 2) (/ (floor index 4) 95)))))

(defmethod character-position ((self text-cgr) char)
  (let ((angle (character-angle self char)))
    (values (cos angle)
            (sin angle))))





(defun cgr-string (view string &key (type 'text-cgr))
  (let ((cgr (make-instance type)))
    (cgr-char-circle cgr view)
    (plot-cgr-aux cgr
                  view
                  (let ((index 0)
                        (length (length string)))
                    #'(lambda ()
                        (if (< index length)
                          (prog1
                            (char string index)
                            (incf index))
                          nil))))))

(defun cgr-file (view filename &key (type 'text-cgr))
  (let ((cgr (make-instance type)))
    (cgr-char-circle cgr view)
    (with-open-file (stream filename :direction :input)
      (plot-cgr-aux cgr
                    view
                    #'(lambda ()
                        (let ((char (read-char stream NIL :EOF)))
                          (if (eq char :EOF)
                            nil
                            char)))))))
  


#|

;; This version does some color stuff.

(defun plot-cgr-aux (cgr view char-getter)
  (reset-cgr cgr)
  (let* ((radius (view-radius view))
         (center (view-center view))
         (center-x (point-h center))
         (center-y (point-v center)))
    (set-pixel view *black-color* center-x center-y)
    (do ((char (funcall char-getter) (funcall char-getter))
         (hue 0.0 (mod (+ hue .01) 1.0)))
        ((null char) (values))
      (when (char-valid-p cgr char)
        (advance-cgr cgr char)
        (set-pixel view
                   (make-hsv-color hue 1.0 1.0)
                   (round (+ center-x (* radius (cgr-x cgr))))
                   (round (+ center-y (* radius (cgr-y cgr)))))))))
|#


(defun plot-cgr-aux (cgr view char-getter)
  (reset-cgr cgr)
  (let* ((radius (view-radius view))
         (center (view-center view))
         (center-x (point-h center))
         (center-y (point-v center)))
    (set-pixel view *black-color* center-x center-y)
    (do ((char (funcall char-getter) (funcall char-getter)))
        ((null char) (values))
      (when (char-valid-p cgr char)
        (advance-cgr cgr char)
        (set-pixel view
                   *black-color*
                   (round (+ center-x (* radius (cgr-x cgr))))
                   (round (+ center-y (* radius (cgr-y cgr)))))))))


#|

(let ((w (make-instance 'window
           :view-size #@(500 500)))
      (f (choose-file-dialog)))
  (sleep 0.5)
  (cgr-file w f))

(let ((w (make-instance 'window
           :view-size #@(500 500)))
      (s (let ((s (make-string 30000 :initial-element #\Space)))
           (dotimes (i 20000)
             (setf (char s (random 30000)) (code-char (random 256))))
           s)))
  (sleep 0.5)
  (cgr-string w s))

(let ((w (make-instance 'window
           :view-size #@(500 500)))
      (s (let ((s (make-string 30000))
               (chars (coerce (cgr-characters (make-instance 'text-cgr))
                              'vector)))
           (dotimes (i 30000)
             (setf (char s i)
                   (code-char (+ (char-code #\0) (mod i 10)))))
           s)))
  (sleep 0.5)
  (cgr-string w s))

(let ((w (make-instance 'window
           :view-size #@(500 500)))
      (s (let ((s (make-string 30000)))
           (dotimes (i 30000)
             (setf (char s i) (code-char (+ (char-code #\0)
                                            (random 10)))))
           s)))
  (sleep 0.5)
  (time (cgr-string w s)))

(let ((w (make-instance 'window
           :view-size #@(500 500)))
      (s (let ((s (make-string 30000)))
           (dotimes (i 30000)
             (setf (char s i) (code-char (+ (char-code #\0)
                                            (round (/ (random 10)
                                                      (+ (random 2) 1)))))))
           s)))
  (sleep 0.5)
  (cgr-string w s))

|#


;(defun get-pixel-color (view h &optional v)
;    (with-focused-view view
;      (rlet ((rgb :RGBColor))
;        (setq h (make-point h v))
;        (if (#_PtInRgn h (pref (wptr view) windowRecord.visrgn))
;          (progn (#_GetCPixel :long h :pointer rgb)
;                 (rgb-to-color rgb))
;          nil))))
;
;(defun element-intensity (view h v size)
;  (let ((sum 0))
;    (dotimes (i size)
;      (dotimes (j size)
;        (incf sum (intensity (get-pixel-color view (+ h i) (+ v j))))))
;    (/ (/ sum (* size size))
;       65535.0)))




(defun view-radius (view)
  (- (floor (min (view-width view) (view-height view)) 2) 15))

(defun view-center (view)
  (make-point (floor (view-width view) 2)
              (floor (view-height view) 2)))


(defun set-pixel (view color h &optional v)
  (with-focused-view view
    (with-rgb (rgb (cond ((eq color T)
                          *black-color*)
                         ((eq color nil)
                          *white-color*)
                         (T color)))
      (setq h (make-point h v))
      (#_SetCPixel (point-h h) (point-v h) rgb))))


;; From Rainer Joswig (See VRML examples in CL-HTTP)

(defun hsv->rgb (h s v)
  "Converts color from HSV to RGB.
   H is between 0.0 and 2pi.
   S and V are between 0.0 and 1.0.
   Returns values for R, G and B.
   Sure Genera has this already.
   See: Computer Graphics, Principles and Practice, Second Edition in C,
   by Foley/van Dam/Feiner/Hughes, Section 13.3.4, The HSV Color Model."
  (let ((2pi (* 2 pi))
        (pi/3 (/ pi 3)))
    (assert (<= 0.0 h 2pi) (h))
    (assert (<= 0.0 s 1.0) (s))
    (assert (<= 0.0 v 1.0) (v))
    (if (zerop s)
      (values v v v)
      (let* ((i (truncate (setf h (/ (if (>= h 2pi) 0.0 h)
                                     pi/3))))
             (f (- h i)))
        (let ((p (* v (- 1.0 s)))
              (q (* v (- 1.0 (* s f))))
              (t1 (* v (- 1.0 (* s (- 1.0 f))))))
          (ecase i
            (0 (values v  t1 p))
            (1 (values q  v  p))
            (2 (values p  v  t1))
            (3 (values p  q  v))
            (4 (values t1 p  v))
            (5 (values v  p  q))))))))


;; Bill St. Clair's faster, MCL-only version

; The built-in version has signed-integer components
(defrecord HSVColor
  (hue :unsigned-integer)               ; Fraction of circle, red at 0
  (saturation :unsigned-integer)        ; 0-1, 0 for gray, 1 for pure color
  (value :unsigned-integer)             ; 0-1, 0 for black, 1 for max intensity
  )



(defun make-hsv-color (hue saturation value)
  (flet ((convert-float (x)
           (cond ((floatp x)
                  (unless (<= 0.0 x 1.0)
                    (error "~s is not between 0.0 & 1.0" x))
                  (floor x (/ 1.0 65535)))
                 ((and (fixnump x)
                       (locally (declare (fixnum x))
                         (and (<= 0 x) (<= x 65535))))
                  x)
                 (t (error "~s is not a float between 0 & 1 or a fixnum ~
                            between 0 & 65535"
                           x)))))
    (setq hue (convert-float hue)
          saturation (convert-float saturation)
          value (convert-float value))
    (rlet ((hsv :HSVColor
                :hue hue
                :saturation saturation
                :value value)
           (rgb :RGBColor))
      (#_HSV2RGB hsv rgb)
      (rgb-to-color rgb))))

(defun color-hsv-values (color &optional floatp)
  (rlet ((rgb :RGBColor)
         (hsv :HSVColor))
    (color-to-rgb color rgb)
    (#_RGB2HSV rgb hsv)
    (flet ((convert-it (x)
             (if floatp
               (/ (float x) 65535.0)
               x)))
      (declare (dynamic-extent #'convert-it))
      (values (convert-it (pref hsv :HSVColor.hue))
              (convert-it (pref hsv :HSVColor.saturation))
              (convert-it (pref hsv :HSVColor.value))))))

(defun color-hue (color &optional floatp)
  (nth-value 0 (color-hsv-values color floatp)))

(defun color-saturation (color &optional floatp)
  (nth-value 1 (color-hsv-values color floatp)))

(defun color-value (color &optional floatp)
  (nth-value 2 (color-hsv-values color floatp)))