(in-package :de.anvi.croatoan)

;; (defclass name (superclasses) (slots) class-options)

;;; data types

;; will be abbreviated as "xchar" or "xch" in function parameters.
(defclass complex-char ()
  ((simple-char
    :initarg       :simple-char
    :initform      nil
    :type          (or null integer character keyword)
    :accessor      simple-char
    :documentation "Lisp primitive character type, like #\a.")

   (attributes
    :initarg       :attributes
    :initform      '()
    :type          (or null cons)
    :accessor      attributes
    :documentation "List of keywords denoting attributes.")

   (fgcolor
    :initarg       :fgcolor
    :initform      nil
    :type          (or null keyword integer list)
    :accessor      fgcolor
    :documentation "A keyword denoting the foreground color of the complex character.")

   (bgcolor
    :initarg       :bgcolor
    :initform      nil
    :type          (or null keyword integer list)
    :accessor      bgcolor
    :documentation "A keyword denoting the background color of the complex character."))

  (:documentation
   "A complex char consists of a simple char, a list of attribute keywords and a pair of color keywords."))

(defmethod initialize-instance :after ((xch complex-char) &key color-pair)
  "If color-pair is passed as a keyword, set fgcolor and bgcolor."
  (when color-pair
    (with-slots (fgcolor bgcolor) xch
      (setf fgcolor (car color-pair)
            bgcolor (cadr color-pair)))))

(defun set-equal (list-a list-b &key (test #'eq) (key #'identity))
  "Compare if every element of list-a is contained in list-b.

The order  of elements in lists does not matter, so the lists are actually treated as sets.

The items of the set are extracted using function 'key' and compared using predicate 'test'."
  (and (= (length list-a) (length list-b))
       (null (set-exclusive-or list-a list-b :test test :key key))))

(defun complex-char= (a b)
  "Return t if the simple-char, the color pair and the attribute list of a complex-char are equal.

The initial purpose of this function is to be used as the equality test for alexandria:define-constant."
  (with-accessors ((simple-char-a simple-char)
                   (bgcolor-a     bgcolor)
                   (fgcolor-a     fgcolor)
                   (attributes-a  attributes)) a
    (with-accessors ((simple-char-b simple-char)
                     (bgcolor-b     bgcolor)
                     (fgcolor-b     fgcolor)
                     (attributes-b  attributes)) b
      (let* ((simple-char-equals-p (cond
                                     ((null simple-char-a)
                                      (null simple-char-b))
                                     ((and (characterp simple-char-a)
                                           (characterp simple-char-b))
                                      (char= simple-char-a
                                             simple-char-b))
                                     ((and (integerp simple-char-a)
                                           (integerp simple-char-b))
                                      (= simple-char-a
                                         simple-char-b))
                                     (t ; mixed type or keyword
                                      (equalp simple-char-a
                                              simple-char-b)))))
        (and simple-char-equals-p
             (equalp fgcolor-a fgcolor-b)
             (equalp bgcolor-a bgcolor-b)
             (set-equal attributes-a attributes-b))))))

(defmethod make-load-form ((object complex-char) &optional environment)
  "Describe how complex-char objects can be serialized and loaded by the compiler."
  (make-load-form-saving-slots object
                               :slot-names '(simple-char attributes color-pair)
                               :environment environment))

(defclass complex-string ()
  ((complex-char-array
    :initarg       :complex-char-array
    :initform      (make-array 0 :element-type 'complex-char :fill-pointer 0 :adjustable t)
    :type          vector
    :accessor      complex-char-array
    :documentation "Lisp primitive string type."))

  (:documentation
   "A complex string consists of an array of complex characters."))

;; TODO: what to do when there is no init string, when we start empty and build the string char by char,
;; for example when extracting a complex string.
(defmethod initialize-instance :after ((cstr complex-string) &key string attributes fgcolor bgcolor color-pair)
  (with-slots (complex-char-array) cstr
    (when string
      (loop for char across string
         do (vector-push-extend
             (make-instance 'complex-char :simple-char char :attributes attributes
                            :fgcolor fgcolor :bgcolor bgcolor :color-pair color-pair)
             complex-char-array)))))

(defclass keymap ()
  ((bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation "Alist of events and handler functions."))

  (:documentation  "A keymap contains an alist of events as keys and event handlers or chained keymaps as values."))

;; initialize instance takes a plist initarg and converts it to an alist.
(defmethod initialize-instance :after ((keymap keymap) &key bindings-plist)
  (with-slots (bindings) keymap
    (when (and (null bindings) bindings-plist)
      (setf bindings (plist2alist bindings-plist)))))

(defclass window (fundamental-character-input-stream fundamental-character-output-stream)
  ((location
    :initarg       :location
    :initform      '(0 0)
    :type          cons
    :documentation "The (y=row x=column) coordinate of the top left corner of the window.")

   (width
    :initarg       :width
    :initform      nil
    :type          (or null integer)
    :documentation "The width (second, horizontal, x dimension) of the window.")

   (height
    :initarg       :height
    :initform      nil
    :type          (or null integer)
    :documentation "The height (first, vertical, y dimension) of the window.")

   ;; has to be a 2el-list so we can use 1 arg with setf.
   (cursor-position
    :type          cons
    :documentation "The current cursor position coordinates in the form (y x).")

   (input-blocking
    :initarg       :input-blocking
    :initform      t
    :type          (or boolean integer)
    :documentation "Input mode: blocking (t), non-blocking (nil) or blocking duration in (positive integer) miliseconds.")

   (frame-rate
    :initarg       :frame-rate
    :initform      nil
    :type          (or null integer)
    :accessor      frame-rate
    :documentation "Set the frame rate in fps (frames per second). When input-blocking is nil, sleep for 1/frame-rate seconds between event loop cycles. Has the same effect as setting input-blocking duration, and should thus not be used simultaneously.")

   (function-keys-enabled-p
    :initarg       :enable-function-keys
    :initform      nil
    :type          boolean
    :documentation "Enable (t) or disable (nil) support for function keys.")

   (scrolling-enabled-p
    :initarg       :enable-scrolling
    :initform      nil
    :type          boolean
    :documentation "Enable (t) or disable (nil) support for window scrolling.")

   (scrolling-region
    :initarg       :scrolling-region
    :initform      nil
    :type          (or null cons)
    :documentation "When scrolling is enabled, only scroll the window region from line y1 to y2 given as the list (y1 y2).")

   ;; IC / INS / Insert / Einfg key
   ;; this will only apply to lisps standard output functions.
   ;; ncurses functions add-char and insert-char can be used explicitely.
   (insert-mode-p
    :initarg       :insert-mode
    :initform      nil
    :type          boolean
    :accessor      insert-mode-p
    :documentation "Printing a new char will insert (t) it before the character under the cursor instead of overwriting it (nil, default).")

   ;; we need instance-local bindings so we dont have to create a keymap for every window and every program
   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   ;; if using an instance-local binding isnt sufficient, we can create a keymap and reference it in the object.
   (keymap
    :initarg       :keymap
    :initform      nil
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings.")

   (background
    :initarg       :background
    :initform      nil
    :type          (or null complex-char)
    :documentation
    "Sets a complex char with its attributes and colors as the default style of unrendered text and empty cells of the window. 
    Complex chars with pre-existing attributes and colors are not changed.")

   (attributes
    :initarg       :attributes
    :initform      nil
    :type          (or null cons)
    :documentation "A list of keywords denoting attributes of new characters added to a window.")

   (fgcolor
    :initarg       :fgcolor
    :initform      nil
    :type          (or null keyword integer list)
    :documentation "A keyword denoting the foreground color of new characters added to the window.")
   
   (bgcolor
    :initarg       :bgcolor
    :initform      nil
    :type          (or null keyword integer list)
    :documentation "A keyword denoting the background color of new characters added to the window.")

   (draw-border-p
    :initarg       :draw-border
    :initform      nil
    :type          boolean
    :reader        draw-border-p
    :documentation "Draw (t) or don't draw (nil, default) an initial border around a window. Not redrawn automatically.")

   (stackedp
    :initarg       :stacked
    :initform      nil
    :type          boolean
    :documentation "If stacked is t, the window is added to the global window stack, so overlapping windows can be refreshed in the stacking order.")

   (visiblep
    :initarg       :visible
    :initform      t
    :type          boolean
    :accessor      visiblep
    :documentation "If visible is nil, do not refresh the stacked window when refreshing the window stack.")

   (winptr
    :initform      nil
    :reader        winptr
    :documentation "Pointer to a C/ncurses WINDOW structure after the window is created."))

  (:documentation "A curses window object as returned by newwin."))

;; also see source/panel.lisp
(defparameter *window-stack* nil)

;; ":stacked t" or "(setf (stackedp win) t)" adds a new window to the stack
;; "(setf (hidden win) t)" prevents the window from being refreshed.
(defmethod stackedp ((win window))
  (slot-value win 'stackedp))
(defmethod (setf stackedp) (stackedp (win window))
  (if stackedp
      ;; t:   check if in stack, if not, add to stack, if yes, error
      (if (member win *window-stack* :test #'eq)
          (error "setf stackedp t: window already on stack")
          (progn
            (push win *window-stack*)
            (setf (slot-value win 'stackedp) t)))
      ;; nil: check if in stack, if yes, remove from stack, if not, error
      (if (member win *window-stack* :test #'eq)
          (progn
            (setf *window-stack* (remove win *window-stack* :test #'eq))
            (setf (slot-value win 'stackedp) t))
          (error "setf stackedp nil: window not on stack"))))

(defclass screen (window)
  ((colors-enabled-p
    :initarg       :enable-colors
    :initform      nil
    :type          boolean
    :documentation "Enable (t) or disable (nil) display of colors, if the terminal supports it.")

   (use-terminal-colors-p
    :initarg       :use-terminal-colors
    :initform      nil
    :type          boolean
    :documentation
    "Use (t) colors set by the terminal (named :terminal) as the default instead of the ncurses default white on black.")

   (cursor-visible-p
    :initarg       :cursor-visible
    :initform      t
    :type          boolean
    :documentation "Enable (t) or disable (nil) the display of a visible cursor.")

   (input-echoing-p
    :initarg       :input-echoing
    :initform      t
    :type          boolean
    :documentation "Enable (t) or disable (nil) echoing of chars during keyboard input.")

   (input-buffering-p
    :initarg       :input-buffering
    :initform      nil
    :type          boolean
    :documentation
    "Set whether typed characters will be returned immediately when they are typed (nil, default) 
    or buffered until Return is typed (t).")

   (process-control-chars-p
    :initarg       :process-control-chars
    :initform      t
    :type          boolean
    :documentation
    "If input-buffering is nil, set whether some control characters like ^C, ^S, ^Q, ^D will be processed (t, default) 
    or passed directly to the program (nil).
    When input-buffering is t, control chars are always processed and this option has no effect.")

   (newline-translation-enabled-p
    :initarg       :enable-newline-translation
    :initform      t
    :type          boolean
    :documentation
    "If t (default), the #\return character (CR ^M \r) is automatically translated to newline (NL) on input, 
     and NL is translated to CR LF on output. 
     NL is the standard, system independent, portable way to end a line.
     It can be either #\linefeed (LF ^J \n) on Linux, carriage #\return on MacOS, CRLF \r\n on Windows.
     Setting newline translation to nil is necessary to be able to detect the #\return key.")

   (closed-p
    :type          boolean
    :documentation "Check whether the screen has been closed, without a subsequent call to refresh to reactivate it."))

  (:documentation "Represents the main window created upon screen initialisation."))

(defclass sub-window (window)
  ((parent
    :initarg       :parent
    :initform      nil
    :type          (or null window)
    :documentation "The parent window which will contain the sub-window.")

   (relativep
    :initarg       :relative
    :initform      nil
    :type          boolean
    :documentation "The location of the sub-window is relative to the parent window (t) or to the screen (nil, default).")

   (source-location
    :initarg       :source-location
    :initform      nil
    :type          (or null cons)
    :documentation
    "Location (y x) of the area of the parent window, which is mapped to the subwindow. 
    By default it is identical to the location of the subwindow."))

  (:documentation  "A sub-window shares the memory and the display with and has to be contained within a parent window."))

(defclass decorated-window (window)
  ((sub-window
    :initarg       :sub-window
    :initform      nil
    :type          (or null sub-window)
    :reader        sub-window
    :documentation "Active content window, for example for menu items.")

   (title
    :initarg       :title
    :initform      nil
    :accessor      title
    :type          (or boolean string)
    :documentation "If t, a title of the window will be displayed over the top border."))

  (:documentation  "A decorated-window is a window consisting of a background window for a border, a title and a content sub-window."))

(defclass menu-item ()
  ((name
    :initarg       :name
    :initform      nil
    :reader        name
    :type          (or null string symbol)
    :documentation "Short name of a menu item displayed in the menu.")

   (checkedp
    :initarg       :checked
    :initform      nil
    :accessor      checkedp
    :type          boolean
    :documentation "t if the item has been checked, nil if it hasn't.")

   (value
    :initarg       :value
    :initform      nil
    :reader        value
    :type          (or symbol string menu menu-window function)
    :documentation "Object associated with and returned upon selection of the item."))
  
  (:documentation  "A menu consists of a list of menu items."))

;; default size of ncurses menus is 16 rows, 1 col.
(defclass menu (element)
  ((name
    :initarg       :name
    :initform      nil
    :reader        name
    :type          (or null string symbol)
    :documentation "Name of the menu. (For example for setting the menu-window title, if title is t.)")

   (items
    :initarg       :items
    :initform      nil
    :accessor      items
    :type          (or null cons)
    :documentation "List of menu items. Item types can be strings, symbols, other menus or callback functions.")

   (menu-type
    :initarg       :menu-type
    :initform      :selection
    :accessor      menu-type
    :type          keyword
    :documentation "Types of menus: :selection (default, can contain strings, symbols, menus) or :checklist.")

   (menu-location
    :initarg       :menu-location
    :initform      nil
    :accessor      menu-location
    :type          (or null cons)
    :documentation "Relative location of the menu within its associated window.")

   (current-item-number
    :initform      0
    :accessor      current-item-number
    :type          integer
    :documentation "Number of the currently selected item.")

   (current-item
    :initform      nil
    :type          (or null string symbol menu-item)
    :accessor      current-item
    :documentation "Pointer to the currently selected item object. The first item is initialized as the current item.")

   (current-item-location
    :initarg       :current-item-location
    :initform      nil
    :accessor      current-item-location
    :type          (or null cons)
    :documentation
    "Location of the current item in the window.
    This information is useful for positioning the cursor on the current item after displaying the menu.")

   (current-item-mark
    :initarg       :current-item-mark
    :initform      ""
    :reader        current-item-mark
    :type          string
    :documentation "A string prefixed to the current item in the menu.")

   (cyclic-selection-p
    :initarg       :cyclic-selection
    :initform      nil
    :accessor      cyclic-selection-p
    :type          boolean
    :documentation "Wrap around when the end of a non-scrolled menu is reached.")

   (max-item-length
    :initarg       :max-item-length
    :initform      15
    :accessor      max-item-length
    :type          integer
    :documentation "Max number of characters displayed for a single item.")

   (layout
    :initarg       :layout
    :initform      nil
    :accessor      layout
    :type          (or null cons)
    :documentation "Layout (no-of-rows no-of-columns) of the items in the menu. If nil, we have a vertical list.")

   (scrolled-layout
    :initarg       :scrolled-layout
    :initform      nil
    :accessor      scrolled-layout
    :type          (or null cons)
    :documentation "Layout (no-of-rows no-of-columns) of the menu items actually displayed on screen.")

   (scrolled-region-start
    :initform      (list 0 0)
    :accessor      scrolled-region-start
    :type          (or null cons)
    :documentation "A 2-element list tracking the starting row/y and column/x of the displayed menu region.")

   ;; we need instance-local bindings so we dont have to create a keymap for every window and every program
   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   ;; if using an instance-local binding isnt sufficient, we can create a keymap and reference it in the object.
   (keymap
    :initarg       :keymap
    :initform      'menu-map
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings.")

   (window
    :initarg       :window
    :initform      nil
    :type          (or null window)
    :accessor      window
    :documentation "Window created separately and then associated with the menu."))

  (:documentation  "A menu is a list of items that can be selected by the user."))

(defclass menu-window (menu decorated-window)
  ()
  (:documentation "A menu-window is decorated-window providing a list of items to be selected by the user."))

;; init for menus which aren't menu windows
(defmethod initialize-instance :after ((menu menu) &key)
  (with-slots (type items current-item layout) menu
    ;; Convert strings and symbols to item objects
    (setf items (mapcar (lambda (x)
                          (if (typep x 'menu-item)
                              ;; if an item object is given, just return it
                              x
                              ;; if we have strings, symbols or menus, convert them to menu-items
                              (make-instance 'menu-item
                                             :name (typecase x
                                                     (string x)
                                                     (symbol (symbol-name x))
                                                     (menu-window (name x))
                                                     (menu (name x)))
                                             :value x)))
                        ;; apply the function to the init arg passed to make-instance.
                        items))

    ;; Initialize the current item as the first item from the items list.
    (setf current-item (car items))

    ;; if the layout wasnt passed as an argument, initialize it as a single one-column menu.
    (unless layout (setf layout (list (length items) 1))) ))

(defmethod initialize-instance :after ((win menu-window) &key color-pair)
  (with-slots (winptr items type height width location sub-window draw-border-p layout scrolled-layout max-item-length
                      current-item-mark fgcolor bgcolor) win
    ;; only for menu windows
    (when (eq (type-of win) 'menu-window)
      (let ((padding (if draw-border-p 1 0)))
        ;; if no layout was given, use a vertical list (n 1)
        (unless layout (setf layout (list (length items) 1)))
        ;; if height and width are not given as initargs, they will be calculated,
        ;; according to no of rows +/- border, and _not_ maximized like normal windows.
        (unless height (setf height (+ (* 2 padding) (car (or scrolled-layout layout)))))
        (unless width  (setf width  (+ (* 2 padding) (* (cadr (or scrolled-layout layout))
                                                        (+ (length current-item-mark) max-item-length)))))
        (setf winptr (%newwin height width (car location) (cadr location)))
        (setf sub-window
              (make-instance 'sub-window
                             :parent win :height (car (or scrolled-layout layout))
                             :width (* (cadr (or scrolled-layout layout)) (+ (length current-item-mark) max-item-length))
                             :location (list padding padding) :relative t))
        (cond ((or fgcolor bgcolor)
               (set-color-pair winptr (color-pair win))
               (setf (color-pair sub-window) (color-pair win)
                     (background win) (make-instance 'complex-char :color-pair (color-pair win))
                     (background sub-window) (make-instance 'complex-char :color-pair (color-pair win)) ))
              ;; when a color-pair is passed as a keyword
              (color-pair
               ;; set fg and bg, pass to ncurses
               (setf (color-pair win) color-pair
                     (color-pair sub-window) color-pair
                     (background win) (make-instance 'complex-char :color-pair color-pair)
                     (background sub-window) (make-instance 'complex-char :color-pair color-pair)))) ))))

(defclass dialog-window (menu-window)
  ;; this has to be a pad, so we can scroll it if the message is large.
  ;; TODO: check how scrolling would work with a subwindow.
  ((message-pad
    :initform      nil
    :type          (or null pad)
    :reader        message-pad
    :documentation "Passive content window, for example for menu descriptions.")

   ;; check how message is called in the dialog program.
   (message-text
    :initarg       :message-text
    :initform      nil
    :accessor      message-text
    :type          (or null string)
    :documentation "Optional message text to describe the choices in the menu below.")
   ;; make shorter slot names
   (message-height
    :initarg       :message-height
    :initform      0
    :reader        message-height
    :type          integer
    :documentation "Max number of lines reserved for the optional message text.")

   (message-pad-coordinates
    :initform      nil
    :reader        message-pad-coordinates
    :type          (or null cons)
    :documentation "List of four coordinates where to refresh/display the message pad: min-y min-x max-y max-x."))

  (:documentation  "A dialog is a decorated menu with a title, a message and items."))

(defmethod initialize-instance :after ((win dialog-window) &key color-pair center)
  (with-slots (winptr items height width location sub-window draw-border-p layout max-item-length current-item-mark
                      fgcolor bgcolor message-pad message-text message-height message-pad-coordinates) win
    ;; only for dialog windows
    (when (eq (type-of win) 'dialog-window)

      ;; dialog windows should always have borders
      (let ((padding 1))
        ;; if no layout was given, use a vertical list (n 1)
        (unless layout (setf layout (list (length items) 1)))

        ;; if height and width are not given as initargs, they will be calculated,
        ;; according to no of rows +/- border, and _not_ maximized like normal windows.
        (unless height (setf height (+ 2 message-height (* 2 padding) (car layout))))
        (unless width (setf width (+ (* 2 padding) (* (cadr layout) (+ (length current-item-mark) max-item-length)))))

        ;; if the key center was given, calculate location automatically, even if it was explicitely given.
        (when center (setf location (list (- (round (/ %LINES 2)) (round (/ height 2)))
                                          (- (round (/ %COLS  2)) (round (/ width  2))))))

        (setf winptr (%newwin height width (car location) (cadr location)))
        (setf sub-window
              (make-instance 'sub-window
                             :parent win :height (car layout)
                             :width (* (cadr layout) (+ (length current-item-mark) max-item-length))
                             :location (list (+ 2 message-height padding) (+ padding 1)) :relative t))

        ;; if there is space reserved for a message, and the message is provided,
        ;; initialize a pad and set the background color.
        (when (and message-text (> message-height 0))
          (setf message-pad (make-instance 'pad :height message-height :width (- width 4)))
          (setf message-pad-coordinates
                (list (+ 2 (car location)) ;screen-min-y
                      (+ 2 (cadr location)) ;screen-min-x
                      (+ (+ 2 (car location)) message-height) ;screen-max-y
                      (+ (+ 2 (cadr location) (- width 4))))) ;screen-max-x
          (when color-pair
            (setf (background message-pad) (make-instance 'complex-char :color-pair color-pair)))
          (format message-pad message-text))

        ;; TODO: do this once for all menus and dialogs, at the moment it is duplicated
        (cond ((or fgcolor bgcolor)
               (set-color-pair winptr (color-pair win))
               (setf (color-pair sub-window) (color-pair win)
                     (background win) (make-instance 'complex-char :color-pair (color-pair win))
                     (background sub-window) (make-instance 'complex-char :color-pair (color-pair win)) ))
              ;; when a color-pair is passed as a keyword
              (color-pair
               ;; set fg and bg, pass to ncurses
               (setf (color-pair win) color-pair
                     (color-pair sub-window) color-pair
                     (background win) (make-instance 'complex-char :color-pair color-pair)
                     (background sub-window) (make-instance 'complex-char :color-pair color-pair)))) ))))

(defclass element ()
  ((name
    :initarg       :name
    :initform      nil
    :reader        name
    :type          (or null symbol keyword string)
    :documentation "Optional unique name by which the element can be identified and accessed.")

   (title
    :initarg       :title
    :initform      nil
    :accessor      title
    :type          (or null string)
    :documentation "Title of the element to be displayed at an location depending on the element type.")

   (value
    :initarg       :value
    :initform      nil
    :accessor      value
    :type          (or symbol keyword string number)
    :documentation "Value of the element, mostly the result of the form editing.")

   (location
    :initarg       :location
    :initform      nil
    :type          (or null cons)
    :accessor      location
    :documentation "A two-element list (y=row x=column) containing the coordinate of the top left corner of the element.")

   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   (keymap
    :initarg       :keymap
    :initform      nil
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings.")
   
   ;; we need this to draw selected and other elements with different styles.
   ;; this has to be toggled at the same time as current-element of a form
   (selectedp
    :initform      nil
    :type          boolean
    :accessor      selectedp
    :documentation "Flag denoting whether the element is currently selected in a form.")

   (activep
    :initform      t
    :type          boolean
    :accessor      activep
    :documentation "If t (default), the element can be selected. Used to prevent labels from being selected.")

   (parent-form
    :initform      nil
    :type          (or null form)
    :accessor      parent-form
    :documentation "Parent form of the element. Added to every element upon the initialization of the form.")

   ;; elements do not necessarily have to have an associated window, only when they are used stand-alone.
   ;; when they are part of a form, we can reference the window associated with the parent form.
   (window
    :initarg       :window
    :initform      nil
    :type          (or null window)
    :documentation "If the element is not part of a form, a window can also be associated with the stand-alone element."))

  (:documentation "An element of a form, like a field or button."))

;; (window (if (window field) (window field) (window (parent-form field))))
(defmethod window ((element element))
  "Return the window associated with an element, which can optionally be part of a form.

If there is no window asociated with the element, return the window associated with the parent form."
  (with-slots (window parent-form) element
    (if window
        window
        (if parent-form
            (if (slot-value parent-form 'window)
                (slot-value parent-form 'window)
                (error "(window element) ERROR: No window is associated with the parent form."))
            (error "(window element) ERROR: Neither a window nor a parent form are associated with the element.")))))

(defmethod (setf window) (window (element element))
  (setf (slot-value element 'window) window))

(defmethod style ((element element))
  "If the element's style slot is empty, check whether a default style has been defined in the parent form."
  (with-slots (style parent-form) element
    (if style
        style
        (if (slot-value parent-form 'style)
            ;; get the default element style from the form style slot.
            (getf (slot-value parent-form 'style) (type-of element))
            nil))))

(defmethod (setf style) (style (element element))
  (setf (slot-value element 'style) style))

(defclass label (element)
  ((reference
    :initarg       :reference
    :initform      nil
    :accessor      reference
    :type          (or null symbol keyword string)
    :documentation
    "If the name of a reference element is specified, the element's title will be displayed instead of the label's.
    If a title for the label is explicitely provided, it overrides the title of the reference element.")

   (width
    :initarg       :width
    :initform      nil
    :type          (or null integer)
    :accessor      width
    :documentation "The width of the label.")

   (style
    :initarg       :style
    :initform      nil
    :type          (or null cons)
    :documentation "")

   (activep
    :initform      nil
    :documentation "Labels are by default not active and can not be selected when cycling through the elements."))
  
  (:documentation "A string displayed at the specified location."))

(defclass button (element)
  ((callback
    :initarg       :callback
    :initform      nil
    :accessor      callback
    :type          (or null symbol function)
    :documentation "Callback function called when the button is activated.")

   (style
    :initarg       :style
    :initform      nil
    :type          (or null cons)
    :documentation "A plist of two complex-chars (or nil): :foreground and :selected-foreground.")

   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   (keymap
    :initarg       :keymap
    :initform      'button-map
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings."))

  (:documentation "An element that can call a function by pressing enter (or in future, with a mouse click)."))

(defclass checkbox (element)
  ((style
    :initarg       :style
    :initform      nil
    :type          (or null cons)
    :documentation "A plist containing :foreground and :selected-foreground.")

   (checkedp
    :initarg       :checked
    :initform      nil
    :accessor      checkedp
    :type          boolean
    :documentation "t if the checkbox has been checked, nil if it hasn't.")
   
   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   (keymap
    :initarg       :keymap
    :initform      'checkbox-map
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings."))

  (:documentation "A boolean element that can be checked (t) or unchecked (nil)"))

(defclass checklist (menu)
  ((menu-type
    :initarg       :menu-type
    :initform      :checklist
    :type          keyword
    :documentation "The type of the menu is set to :checklist"))

  (:documentation "A checklist is a multi-selection menu with checkable items."))

(defclass field (element)
  ((width
    :initarg       :width
    :initform      nil
    :type          (or null integer)
    :accessor      width
    :documentation "The width of the field. The default buffer length is equal the width.")

   (style
    :initarg       :style
    :initform      nil
    :type          (or null cons)
    :documentation "A plist of four complex-chars (or nil): :foreground, :background, :selected-foreground, :selected-background.")

   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   (keymap
    :initarg       :keymap
    :initform      'field-map
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings.")

   (buffer
    :initform      nil
    :type          (or null list)
    :accessor      buffer
    :documentation "List containing the characters in the field.")

   (max-buffer-length
    :initarg       :max-buffer-length
    :initform      nil
    :type          (or null integer)
    :accessor      max-buffer-length
    :documentation
    "Max length of the field buffer. If nil, it will be initialized to field width. 
    Horizontal scrolling is then disabled.")

   (display-pointer
    :initform      0
    :type          (or null integer)
    :accessor      display-pointer
    :documentation
    "Position in the input buffer from which n=width characters are displayed.
    When max-buffer-length is greater than width, display-pointer can be greater than zero.
    Horizontal scrolling is then enabled.")

   (input-pointer
    :initform      0
    :type          integer
    :accessor      input-pointer
    :documentation "The position in the input buffer to which the next character will be written."))

  (:documentation "A field is an editable part of the screen for user input. Can be part of a form."))

(defmethod initialize-instance :after ((field field) &key)
  (with-slots (max-buffer-length width bindings keymap) field
    ;; If unspecified, the default max-buffer-length should be equal to the visible field width.
    (unless max-buffer-length
      (setf max-buffer-length width))))

(defmethod value ((field field))
  "If the field buffer is empty, return nil, otherwise return the buffer as a string."
  (when (slot-value field 'buffer)
    (coerce (reverse (slot-value field 'buffer)) 'string)))

(defmethod (setf value) (new-value (field field))
  (setf (slot-value field 'buffer) (reverse (coerce new-value 'list))))

(defclass form ()
  ((name
    :initarg       :name
    :initform      nil
    :reader        name
    :type          (or null symbol keyword string)
    :documentation "Name of the form.")

   (elements
    :initarg       :elements
    ;; Make sure we already have fields when we initialize a form.
    :initform      nil
    :type          (or null cons)
    :accessor      elements
    :documentation "List of elements. The first element will be initialized as the current element.")

   ;; if init is 0, what if we have no fields yet?
   (current-element-number
    :initform      0
    :type          integer
    :accessor      current-element-number
    :documentation "Number of the currently selected element.")

   ;; has to be updated every time the current element number is updated.
   (current-element
    :initform      nil
    :type          (or null field button label checkbox menu checklist)
    :accessor      current-element
    :documentation "Currently selected element object.")

   (style
    :initarg       :style
    :initform      nil
    :type          (or null cons)
    :accessor      style
    :documentation "A plist of default styles for each form element type.")

   (bindings
    :initarg       :bindings
    :initform      nil
    :type          (or null cons)
    :accessor      bindings
    :documentation
    "Alist of events (characters, keywords or integers) as keys and handler functions as values. 
    Used by the run-event-loop function.")

   (keymap
    :initarg       :keymap
    :initform      'form-map
    :type          (or null symbol keyword keymap)
    :accessor      keymap
    :documentation "Keymap containing the key bindings to be used by run-event-loop instead of the object's own bindings.")

   (window
    :initarg       :window
    :initform      nil
    :type          (or null window)
    :accessor      window
    :documentation "Window created separately and then associated with the form."))

  (:documentation "A form is a list of fields."))

(defmethod initialize-instance :after ((form form) &key)
  (with-slots (elements current-element bindings keymap) form
    (if elements
        (progn
          ;; Initialize the current element as the first element from the passed elements list.
          ;; we have to set the current element before we can change it with select-previous-element and select-next-element
          (setf current-element (car elements))
          ;; set the selected option of the initial current element.
          (setf (slot-value current-element 'selectedp) t)
          ;; set the parent form slot of every element.
          (loop for element in elements
             do (setf (slot-value element 'parent-form) form)))

        ;; if a list of elements was not passed, signal an error.
        (error "A list of elements is required to initialize a form."))))

(defclass form-window (form decorated-window)
  ()
  (:documentation ""))

(defmethod initialize-instance :after ((win form-window) &key)
  (with-slots (winptr height width location sub-window draw-border-p window) win
    ;; only for form windows
    (when (eq (type-of win) 'form-window)
      (setf winptr (%newwin height width (car location) (cadr location)))
      (setf sub-window (make-instance 'sub-window :parent win :height (- height 2) :width (- width 2)
                                      :location (list 1 1) :relative t :enable-function-keys t))
      ;; set the sub of the decorated window to be the associated window of the form
      ;; the form will be drawn to the associated window, i.e. to the sub
      (setf window sub-window) )))

;; if a window-location is given during make-instance, it can be simply ignored.
;; or we can check for location and signal an error.
(defclass pad (window)
  ()
  (:documentation "A pad is a window without a specified location on screen, which is specified dynamically during refresh."))

(defmethod initialize-instance :after ((win pad) &key)
  (with-slots (winptr height width) win
    ;; just for a pad window
    (when (eq (type-of win) 'pad)
      (setf winptr (%newpad height width)))))

(defclass sub-pad (pad)
  ((parent
    :initarg       :parent
    :initform      nil
    :type          (or null pad)
    :documentation "The parent pad which will contain the sub-pad."))
  (:documentation  "A sub-pad shares the memory and the display with a parent pad and has to be contained within it."))

;; sub-pads always use locations relative to parent pads
(defmethod initialize-instance :after ((win sub-pad) &key)
  (with-slots (winptr parent height width location) win
    ;; just for a sub-pad window
    (when (eq (type-of win) 'sub-pad)
      (setf winptr (%subpad (slot-value parent 'winptr) height width (car location) (cadr location))))))

#|
;; this will be called for both window and screen.
;; create a curses window when an instance is created.
(defmethod initialize-instance :after ((win window) &key)
  (with-slots (winptr cursor-visible-p colors-enabled-p input-echoing-p input-reading 
                      input-blocking function-keys-enabled-p scrolling-enabled-p height width location) win

    ;; different initialisations depending on the window type.
    ;; %initscr initializes a screen, %newwin initializes a window.
    ;; TODO: subwin, derwin, pad...
    ;; CAUTION: these initializations have to be done _before_ any other commands.
    ;; because of that we cant use call-next-method.
    (case (type-of win)
      ;; a screen is initialized when we start ncurses.
      (screen (progn
                (setf winptr (%initscr))
                (when colors-enabled-p (%start-color))
                (if input-echoing-p (%echo) (%noecho))
                (set-input-reading winptr input-reading)
                (set-cursor-visibility cursor-visible-p))) ;kernel.lisp
      ;; a window is initialized when we create a new window.
      (window (setf winptr (%newwin height width (car location) (cadr location)))))

    ;; the following settings have to be executed for all window types.
    (set-input-blocking winptr input-blocking)
    (%scrollok winptr scrolling-enabled-p)
    (%keypad winptr function-keys-enabled-p)))
|#

;; We cant do this because _all_ auxiliary methods are always used and combined.

(defmethod initialize-instance :after ((win window) &key color-pair)
  (with-slots (winptr height width location fgcolor bgcolor background) win
    ;; just for WINDOW types
    (when (eq (type-of win) 'window)
      (unless width (setf width 0))
      (unless height (setf height 0))
      (setf winptr (%newwin height width (car location) (cadr location)))

      ;; fg/bg should not be passed together with the color-pair keyword.
      (cond ((or fgcolor bgcolor)
             (set-color-pair winptr (color-pair win)))
            (color-pair
             ;; set fg and bg, pass to ncurses
             (setf (color-pair win) color-pair)))

      (when background (setf (background win) background)) )))

(defmethod initialize-instance :after ((scr screen) &key color-pair)
  (with-slots (winptr colors-enabled-p use-terminal-colors-p cursor-visible-p input-echoing-p input-blocking
                      function-keys-enabled-p newline-translation-enabled-p fgcolor bgcolor
                      scrolling-enabled-p background input-buffering-p process-control-chars-p) scr
    ;; just for screen window types.
    (when (eq (type-of scr) 'screen)
      (setf winptr (%initscr))
      (when colors-enabled-p
        (if (%has-colors)
            (progn
              (%start-color)
              (set-default-color-pair use-terminal-colors-p))
            (error "initialize-instance screen: This terminal does not support colors.")))

      (cond ((or fgcolor bgcolor)
             (set-color-pair winptr (color-pair scr)))
            (color-pair
             ;; set fg and bg, pass to ncurses
             (setf (color-pair scr) color-pair)))

      (when background (setf (background scr) background))
      (if newline-translation-enabled-p (%nl) (%nonl))
      (if input-echoing-p (%echo) (%noecho))
      (set-input-mode input-buffering-p process-control-chars-p)
      (set-cursor-visibility cursor-visible-p))))

;; sub-window has to be contained within a parent window
;; touch parent before refreshing a subwindow
;; move also needs a method for subwindows.
;; Subwindows must be deleted before the main window can be deleted.
(defmethod initialize-instance :after ((win sub-window) &key)
  (with-slots (winptr parent height width location relativep) win
    ;; leaving out the size of a window maxes it out to the right and to the bottom
    (unless width (setf width 0))
    (unless height (setf height 0))
    ;; just for SUB-WINDOW types
    (when (eq (type-of win) 'sub-window)
      (if relativep
          ;;(setf winptr (%derwin (slot-value parent 'winptr) height width (car location) (cadr location)))
          (setf winptr (let ((val (%derwin (slot-value parent 'winptr) height width (car location) (cadr location))))
                         (if (null-pointer-p val)
                             ;; may also be null if the parent window passed is null
                             (error "Subwindow could not be created. Probably too big and not contained in the parent window.")
                             val)))
          (setf winptr (%subwin (slot-value parent 'winptr) height width (car location) (cadr location)))))))

(defmethod initialize-instance :after ((win decorated-window) &key)
  (with-slots (winptr width height location sub-window) win
    ;; only for decorated window types
    (when (eq (type-of win) 'decorated-window)
      (setf winptr (%newwin height width (car location) (cadr location)))
      (setf sub-window
            (make-instance 'sub-window :parent win :height (- height 2) :width (- width 2) :location (list 1 1) :relative t)))))

;; called after _all_ :after aux methods.
;; for all window types in the hierarchy.
(defmethod initialize-instance :around ((win window) &key)
  ;; before :before, :after and primary.
  (let ((result (call-next-method)))
    ;; after :before, :after and primary.
    (with-slots (winptr input-blocking function-keys-enabled-p scrolling-enabled-p draw-border-p stackedp) win
      (set-input-blocking winptr input-blocking)
      (%scrollok winptr scrolling-enabled-p)
      (when draw-border-p (%box winptr 0 0))
      (%keypad winptr function-keys-enabled-p)
      (when stackedp (push win *window-stack*)))

    ;; why do we have to return the result in :around aux methods?
    result))

;; Accessors

(defgeneric location (window))
(defmethod location ((window window))
  (list (%getbegy (slot-value window 'winptr)) (%getbegx (slot-value window 'winptr))))
(defmethod location ((win sub-window))
  (with-slots (winptr relativep) win
    (if relativep
        (list (%getpary winptr) (%getparx winptr))
        (list (%getbegy winptr) (%getbegx winptr)))))
(defgeneric (setf location) (coordinates window))
(defmethod (setf location) (coordinates (w window))
  (setf (slot-value w 'location) coordinates)
  (%mvwin (slot-value w 'winptr) (car coordinates) (cadr coordinates)))

;; The slots location-y and location-x dont exist, these accessors exist for convenience.

(defgeneric location-y (window))
(defmethod location-y ((win window))
  (%getbegy (slot-value win 'winptr)))
(defmethod location-y ((win sub-window))
  (with-slots (winptr relativep) win
    (if relativep
        (%getpary winptr)
        (%getbegy winptr))))

(defgeneric location-x (window))
(defmethod location-x ((win window))
  (%getbegx (slot-value win 'winptr)))
(defmethod location-x ((win sub-window))
  (with-slots (winptr relativep) win
    (if relativep
        (%getparx winptr)
        (%getbegx winptr))))

(defgeneric (setf location-y) (y window))
(defmethod (setf location-y) (y (win window))
  (let ((x (cadr (slot-value win 'location))))
    (setf (slot-value win 'location) (list y x))
    (%mvwin (slot-value win 'winptr) y x)))

(defgeneric (setf location-x) (x window))
(defmethod (setf location-x) (x (win window))
  (let ((y (car (slot-value win 'location))))
    (setf (slot-value win 'location) (list y x))
    (%mvwin (slot-value win 'winptr) y x)))

;; "The screen-relative parameters of the window are not changed. 
;; This routine is used to display different parts of the parent 
;; window at the same physical location on the screen."
;;
;; "The mvderwin() function specifies a mapping of characters.
;; The function identifies a mapped area of the parent of the specified window"

;; TODO: rename to source-location
(defgeneric (setf source-location) (coordinates sub-window))
(defmethod (setf source-location) (coordinates (w sub-window))
  (setf (slot-value w 'source-location) coordinates)
  (%mvderwin (slot-value w 'winptr) (car coordinates) (cadr coordinates)))

(defgeneric width (window))
(defmethod width ((window window))
  (%getmaxx (slot-value window 'winptr)))

(defgeneric height (window))
(defmethod height ((window window))
  (%getmaxy (slot-value window 'winptr)))

(defgeneric cursor-position (window))
(defmethod cursor-position ((window window))
  (list (%getcury (slot-value window 'winptr)) (%getcurx (slot-value window 'winptr))))

;; we can move the cursor by doing this, or by calling "move". 
;; both will use %wmove in the background.
;; note that incd and decf dont work.
(defgeneric (setf cursor-position) (coordinates window))
(defmethod (setf cursor-position) (coordinates (w window))
  (setf (slot-value w 'cursor-position) coordinates)
  (%wmove (slot-value w 'winptr) (car coordinates) (cadr coordinates)))

;; The slots location-y and location-x dont exist, but the pseudo accessors
;; exist for convenience.

(defgeneric cursor-position-y (window))
(defmethod cursor-position-y ((win window))
  (%getcury (slot-value win 'winptr)))

(defgeneric cursor-position-x (window))
(defmethod cursor-position-x ((win window))
  (%getcurx (slot-value win 'winptr)))

(defgeneric (setf cursor-position-y) (y window))
(defmethod (setf cursor-position-y) (y (win window))
  (let ((x (cadr (slot-value win 'cursor-position))))
    (setf (slot-value win 'cursor-position) (list y x))
    (%wmove (slot-value win 'winptr) y x)))

(defgeneric (setf cursor-position-x) (x window))
(defmethod (setf cursor-position-x) (x (win window))
  (let ((y (car (slot-value win 'cursor-position))))
    (setf (slot-value win 'cursor-position) (list y x))
    (%wmove (slot-value win 'winptr) y x)))

(defgeneric cursor-visible-p (window))
(defmethod cursor-visible-p ((screen screen))
  (slot-value screen 'cursor-visible-p))
(defgeneric (setf cursor-visible-p) (status screen))
(defmethod (setf cursor-visible-p) (status (screen screen))
  (setf (slot-value screen 'cursor-visible-p) status)
  (set-cursor-visibility status))

(defgeneric input-blocking (window))
(defmethod input-blocking ((window window))
  (slot-value window 'input-blocking))
(defgeneric (setf input-blocking) (status window))
(defmethod (setf input-blocking) (status (window window))
  (setf (slot-value window 'input-blocking) status)
  (set-input-blocking (slot-value window 'winptr) status))

(defgeneric function-keys-enabled-p (window))
(defmethod function-keys-enabled-p ((window window))
  (slot-value window 'function-keys-enabled-p))
(defgeneric (setf function-keys-enabled-p) (status window))
(defmethod (setf function-keys-enabled-p) (status (window window))
  (setf (slot-value window 'function-keys-enabled-p) status)
  (%keypad (slot-value window 'winptr) status))

(defgeneric scrolling-enabled-p (window))
(defmethod scrolling-enabled-p ((window window))
  (slot-value window 'scrolling-enabled-p))
(defgeneric (setf scrolling-enabled-p) (status window))
(defmethod (setf scrolling-enabled-p) (status (window window))
  (setf (slot-value window 'scrolling-enabled-p) status)
  (%scrollok (slot-value window 'winptr) status))

(defgeneric scrolling-region (window))
(defmethod scrolling-region ((window window))
  (slot-value window 'scrolling-region))
(defgeneric (setf scrolling-region) (list window))
(defmethod (setf scrolling-region) (list (window window))
  (setf (slot-value window 'scrolling-region) list)
  (%wsetscrreg (slot-value window 'winptr)
               (first  (slot-value window 'scrolling-region))
               (second (slot-value window 'scrolling-region))))
;; TODO: setf only when scrolling is enabled.

(defgeneric input-echoing-p (screen))
(defmethod input-echoing-p ((screen screen))
  (slot-value screen 'input-echoing-p))
(defgeneric (setf input-echoing-p) (status screen))
(defmethod (setf input-echoing-p) (status (screen screen))
  (setf (slot-value screen 'input-echoing-p) status)
  ;;(set-input-echoing status))
  (if status (%echo) (%noecho)))

(defgeneric input-buffering-p (screen))
(defmethod input-buffering-p ((screen screen))
  (slot-value screen 'input-buffering-p))
(defgeneric (setf input-buffering-p) (status screen))
(defmethod (setf input-buffering-p) (status (screen screen))
  (setf (slot-value screen 'input-buffering-p) status)
  (set-input-mode (slot-value screen 'input-buffering-p)
                  (slot-value screen 'process-control-chars-p)))

(defgeneric process-control-chars-p (screen))
(defmethod process-control-chars-p ((screen screen))
  (slot-value screen 'process-control-chars-p))
(defgeneric (setf process-control-chars-p) (status screen))
(defmethod (setf process-control-chars-p) (status (screen screen))
  (with-slots (input-buffering-p process-control-chars-p) screen
    ;; only make a change when the status changed.
    (when (not (eq process-control-chars-p status))
      ;; only call ncurses when buffering is nil.
      (unless input-buffering-p
        ;; before we switch the unbuffered mode, we switch to the default cooked mode.
        (if process-control-chars-p (%nocbreak) (%noraw))
        ;; then make a "clean" switch back to the new unbuffered mode.
        (set-input-mode input-buffering-p status))
      ;; then save the new status.
      (setf process-control-chars-p status) )))

(defgeneric newline-translation-enabled-p (screen))
(defmethod newline-translation-enabled-p ((screen screen))
  (slot-value screen 'newline-translation-enabled-p))
(defgeneric (setf newline-translation-enabled-p) (status screen))
(defmethod (setf newline-translation-enabled-p) (status (screen screen))
  (setf (slot-value screen 'newline-translation-enabled-p) status)
  (if status (%nl) (%nonl)))

(defgeneric background (window))
(defmethod background ((win window))
  (slot-value win 'background))

(defgeneric (setf background) (char window &optional apply))
(defmethod (setf background) (char (window window) &optional (apply t))
  (setf (slot-value window 'background) char)
  ;; ncurses
  ;;(set-background-char (slot-value window 'winptr) char apply))
  ;; ncursesw
  (set-background-cchar_t window char apply))

;(defgeneric attributes (window))
(defmethod attributes ((window window))
  (slot-value window 'attributes))

;;(defgeneric (setf attributes) (attributes window))
#|
(defmethod (setf attributes) (attributes (window window))
  (let ((added (set-difference attributes (slot-value window 'attributes)))
        (removed (set-difference (slot-value window 'attributes) attributes)))
    (setf (slot-value window 'attributes) attributes)
    (add-attributes window added)
    (remove-attributes window removed)))
|#
;; TODO use %wattron and %wattroff here.

(defmethod (setf attributes) (attributes (win window))
  (with-slots ((win-attributes attributes)) win
    (let ((added   (set-difference     attributes win-attributes))
          (removed (set-difference win-attributes     attributes)))
      ;; set the list of attributes to the window slot
      (setf win-attributes attributes)
      ;; pass the attrbutes to add and remove to ncurses
      (add-attributes win added)
      (remove-attributes win removed))))

;; we dont want to use set-attributes because it also overwrites the color attribute.
;; we want the attributes function to just handle attributes and leave the color alone.
;; to do that, we have to treat the attributes as a set and ignore set-attributes.

;; (defmethod (setf attributes) (attributes (window window))
;;   (setf (slot-value window 'attributes) attributes)
;;   (set-attributes window attributes))

(defmethod color-pair ((win window))
  (with-slots (fgcolor bgcolor) win
    (if (or fgcolor bgcolor)
        (list fgcolor bgcolor)
        ;; when both colors are nil, do not return (nil nil) but nil
        nil)))

(defmethod (setf color-pair) (color-pair (win window))
  (with-slots (fgcolor bgcolor) win
    (if color-pair
        (setf fgcolor (car color-pair)
              bgcolor (cadr color-pair))
        ;; when color-pair is nil, both fg and bg are set to nil
        (setf fgcolor nil
              bgcolor nil)))
  ;; after the slots are set, pass the new pair to ncurses
  (set-color-pair (slot-value win 'winptr) (color-pair win)))

(defmethod color-pair ((xch complex-char))
  (with-slots (fgcolor bgcolor) xch
    (if (or fgcolor bgcolor)
        (list fgcolor bgcolor)
        ;; when both colors are nil, do not return (nil nil) but nil
        nil)))

(defmethod (setf color-pair) (color-pair (xch complex-char))
  (with-slots (fgcolor bgcolor) xch
    (if color-pair
        (setf fgcolor (car color-pair)
              bgcolor (cadr color-pair))
        ;; when color-pair is nil, both fg and bg are set to nil
        (setf fgcolor nil
              bgcolor nil))))

(defmethod fgcolor ((win window))
  (slot-value win 'fgcolor))

(defmethod bgcolor ((win window))
  (slot-value win 'bgcolor))

(defmethod (setf fgcolor) (fgcolor (win window))
  (setf (slot-value win 'fgcolor) fgcolor)
  ;; set the color pair in the underlying ncurses lib.
  (set-color-pair (slot-value win 'winptr) (color-pair win)))

(defmethod (setf bgcolor) (bgcolor (win window))
  (setf (slot-value win 'bgcolor) bgcolor)
  ;; set the color pair in the underlying ncurses lib.
  (set-color-pair (slot-value win 'winptr) (color-pair win)))


;;; print, prin1, princ, format ~A, ~S

;; print a wide but simple lisp character to a window
;; TODO: add check for insert-mode
(defmethod print-object ((ch character) (stream window))
  (add-wide-char stream ch))

;; TODO: add check for insert-mode
(defmethod print-object ((ch complex-char) (stream window))
  (add-wide-char stream ch))

;; print only simple chars to the lisp repl.
(defmethod print-object ((ch complex-char) stream)
  (princ (simple-char ch) stream))

;; print simple strings to a ncurses widow.
(defmethod print-object ((str string) (stream window))
  (%waddstr (winptr stream) str))

;; print complex strings to a ncurses window.
(defmethod print-object ((cstr complex-string) (stream window))
  (loop for ch across (complex-char-array cstr)
     do (add-wide-char stream ch)))

;; print only simple chars to the lisp repl.
(defmethod print-object ((cstr complex-string) stream)
  (loop for ch across (complex-char-array cstr)
     do (princ (simple-char ch) stream)))

;; methods to close streams, and thus screen _and_ windows, since they are now gray streams.
;; end-screen = %endwin
;; delete-window = %delwin
;; see t07a
;; remember we cant use open to open a window. it works only for file streams.
;; we have to make-instance of a window or a screen.

(defmethod close ((stream window) &key abort)
  (declare (ignore abort))
  ;; if by time of closing, the window is still on the stack, remove it first.
  (if (member stream *window-stack* :test #'eq)
      (setf *window-stack* (remove stream *window-stack* :test #'eq)))
  (%delwin (winptr stream))
  ;; The default method provided by class FUNDAMENTAL-STREAM sets a flag for OPEN-STREAM-P.
  (call-next-method))

(defmethod close ((stream sub-window) &key abort)
  (declare (ignore abort))
  (%delwin (winptr stream)))

(defmethod close ((stream screen) &key abort)
  (declare (ignore abort))
  (%endwin))

(defmethod close ((stream decorated-window) &key abort)
  (declare (ignore abort))
  (%delwin (winptr (sub-window stream)))
  (%delwin (winptr stream)))

;; although it is not a stream, we will abuse close to close a menu's window and subwindow, which _are_ streams.
(defmethod close ((stream menu-window) &key abort)
  (declare (ignore abort))
  (%delwin (winptr (sub-window stream)))
  (%delwin (winptr stream)))

(defmethod close ((stream dialog-window) &key abort)
  (declare (ignore abort))
  (%delwin (winptr (message-pad stream)))
  (%delwin (winptr (sub-window stream)))
  (%delwin (winptr stream)))

(defmethod close ((stream form-window) &key abort)
  (declare (ignore abort))
  (%delwin (winptr (sub-window stream)))
  (%delwin (winptr stream)))

;; SBCL bug when specializing close on gray streams:
;; STYLE-WARNING:
;;    Generic function CLOSE clobbers an earlier FTYPE proclamation
;;    (FUNCTION (STREAM &KEY (:ABORT T)) (VALUES (MEMBER T) &OPTIONAL)) for the
;; same name with (FUNCTION (T &KEY (:ABORT T)) *).
