;;;
;;; atoms.lisp
;;;
;;; Atom Database
;;;
;;; Copyright (C) 2005, Alastair Bridgewater.
;;;

(in-package :clxs)

#|
;; From the malformed ideas department:
;;   Doesn't work, can't over-allocate the array when using :initial-contents.
(defconstant +initial-atom-table-size+ 100
  "Tuning parameter. How many atoms we can handle before we need to start adjusting the atom table. Needs to be at least (length +initial-atom-list+).")
|#
(defparameter +initial-atom-list+
  '("PRIMARY" "SECONDARY" "ARC" "ATOM" "BITMAP"
    "CARDINAL" "COLORMAP" "CURSOR"
    "CUT_BUFFER0" "CUT_BUFFER1" "CUT_BUFFER2" "CUT_BUFFER3"
    "CUT_BUFFER4" "CUT_BUFFER5" "CUT_BUFFER6" "CUT_BUFFER7"
    "DRAWABLE" "FONT" "INTEGER" "PIXMAP" "POINT"
    "RECTANGLE" "RESOURCE_MANAGER"
    "RGB_COLOR_MAP" "RGB_BEST_MAP" "RGB_BLUE_MAP"
    "RGB_DEFAULT_MAP" "RGB_GRAY_MAP"
    "RGB_GREEN_MAP" "RGB_RED_MAP"
    "STRING" "VISUALID" "WINDOW"
    "WM_COMMAND" "WM_HINTS" "WM_CLIENT_MACHINE"
    "WM_ICON_NAME" "WM_ICON_SIZE" "WM_NAME"
    "WM_NORMAL_HINTS" "WM_SIZE_HINTS" "WM_ZOOM_HINTS"
    "MIN_SPACE" "NORM_SPACE" "MAX_SPACE" "END_SPACE"
    "SUPERSCRIPT_X" "SUPERSCRIPT_Y"
    "SUBSCRIPT_X" "SUBSCRIPT_Y"
    "UNDERLINE_POSITION" "UNDERLINE_THICKNESS"
    "STRIKEOUT_ASCENT" "STRIKEOUT_DESCENT"
    "ITALIC_ANGLE" "X_HEIGHT" "QUAD_WIDTH"
    "WEIGHT" "POINT_SIZE" "RESOLUTION" "COPYRIGHT"
    "NOTICE" "FONT_NAME" "FAMILY_NAME" "FULL_NAME"
    "CAP_HEIGHT" "WM_CLASS" "WM_TRANSIENT_FOR")
  "The list of pre-defined atoms, in order, from atom-id 1 upwards.")

(defvar *num-atoms* 0 "The number of valid atoms.")
(defvar *atom-name-table* nil "An array of atom names, as strings.")

(defun assert-atom-valid (atom-id)
  "Return NIL if ATOM-ID is a valid atom identifier, otherwise invoke the PROTOCOL-ERROR restart with :ATOM and ATOM-ID."
  (if (not (<= 1 atom-id *num-atoms*))
      (invoke-restart 'protocol-error :ATOM atom-id)))

(defun is-valid-atom (atom-id)
  "Return T if ATOM-ID is a valid atom identifier, otherwise return NIL."
  (<= 1 atom-id *num-atoms*))

(defun intern-atom (name only-if-exists)
  "Return an atom-id corresponding to NAME or 0 if such an atom doesn't exist and ONLY-IF-EXISTS is true."
  (or (dotimes (i *num-atoms*)
	(when (string= name (aref *atom-name-table* i))
	  (return (1+ i))))
      
      (when only-if-exists 0)
      
      (progn
	(vector-push-extend name *atom-name-table*)
	(incf *num-atoms*))))

(defun atom-name (atom-id)
  "Return the name of atom ATOM-ID as a string. The consequences of modifying the return value are undefined."
  (assert-atom-valid atom-id)
  (aref *atom-name-table* (1- atom-id)))

(defun reset-atom-database ()
  "Reset the atom database to its initial state (just the pre-defined atoms loaded)."
  (setf *num-atoms* (length +initial-atom-list+))
  (setf *atom-name-table* (make-array *num-atoms*
				      :fill-pointer t
				      :adjustable t
				      :initial-contents +initial-atom-list+))
  nil)

;; FIXME: Add the InternAtom request handler.

(define-x-request get-atom-name (:opcode 17)
    ((opcode :u8 :value 17 :error :implementation)
     (unused :u8)
     (length :u16 :value 2 :error :length)
     (atom :atom))
  (declare (ignore unused))
  (let* ((name (atom-name atom))
	 (response (make-array (+ 32 (logand -4 (+ 3 (length name))))
			       :element-type '(unsigned-byte 8)
			       :initial-element 0)))
    #+nil (format t "Get atom name ~A (~A)~%" atom name)
    (setf (aref response 0) 1)
    (if (eq (client-state-byte-order client) :lsb-first)
	(progn
	  (setf (request-le-u16 response 2)
		(client-state-request-number client))
	  (setf (request-le-u32 response 4)
		(ash (+ 3 (length name)) -2))
	  (setf (request-le-u16 response 8) (length name)))
	(progn
	  (setf (request-be-u16 response 2)
		(client-state-request-number client))
	  (setf (request-be-u32 response 4)
		(ash (+ 3 (length name)) -2))
	  (setf (request-be-u16 response 8) (length name))))
    (dotimes (i (length name))
      (setf (aref response (+ 32 i)) (char-code (aref name i))))
    (send-packet (client-state-network-client client) response)))

;;; EOF
