;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIMI; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: Cut and Paste
;;;   Created: 2003-08-16
;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2003 by Gilbert Baumann

(in-package :climi)

(defparameter *marking-border* 1)

(defparameter *marked-foreground* +white+
  "Foreground ink to use for marked stuff.")

(defparameter *marked-background* +blue4+
  "Background ink to use for marked stuff.")

;;;; Random Notes

;; - McCLIM still has absolutely no idea of lines.

(defclass marking ()
  ()
  (:documentation "A common super class for markings (= stuff marked)."))

(defgeneric marking-region (stream marking)
  (:documentation "Region marked/affected."))

(defgeneric draw-marking (medium marking)
  (:documentation "Draw the marking to medium."))

(defclass string-marking (marking)
  ((record :initarg :record
           :documentation "The text output record this belongs to.")
   (styled-string :initarg :styled-string
                  :documentation "The styled string sub-record of 'record'.")
   (start :initarg :start
          :documentation "Start index within string.")
   (end :initarg :end
        :documentation "End index within string. Caution: Could be one off the end to indicate a newline implied."))
  (:documentation "Some part of a styled-string marked."))

(defmethod marking-region (stream (marking string-marking))
  (with-slots (record styled-string start end) marking
    (with-slots (baseline start-y) record
      (with-slots (start-x string text-style) styled-string
        (make-rectangle* (+ start-x
                            (stream-string-width stream string
                                                 :start 0 :end start
                                                 :text-style text-style)
                            (- *marking-border*))
                         (+ start-y baseline
                            (- (text-style-ascent text-style stream))
                            (- *marking-border*))
                         (+ start-x
                            (stream-string-width stream string
                                                 :start 0 :end end
                                                 :text-style text-style)
                            *marking-border*)
                         (+ start-y baseline (text-style-descent text-style stream)
                            *marking-border*))))))

(defmethod draw-marking (stream (marking string-marking))
  (draw-design (sheet-medium stream) (marking-region marking)
               :ink +flipping-ink+))

;;;;

(defclass cut-and-paste-mixin ()
  ((markings   :initform nil)
   (point-1-x  :initform nil)
   (point-1-y  :initform nil)
   (point-2-x  :initform nil)
   (point-2-y  :initform nil)
   (dragging-p :initform nil) ))

(defmethod handle-repaint :around ((pane cut-and-paste-mixin) region)
  (with-slots (markings) pane
    (cond ((null markings)
           (call-next-method))
          (t
           (let ((marked-region
                  (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) (slot-value pane 'markings))
                          :initial-value +nowhere+)))
             (with-sheet-medium (medium pane)
               (let ((R (region-difference region marked-region)))
                 (with-drawing-options (medium :clipping-region R)
                   (call-next-method pane R))))
             (with-sheet-medium (medium pane)
               (let ((R (region-intersection region marked-region)))
                 (with-drawing-options (medium :clipping-region R)
                   (letf (((medium-foreground medium) *marked-foreground*)
                          ((medium-background medium) *marked-background*))
                     (call-next-method pane R))))))))))

(defclass standard-output-recording-stream (cut-and-paste-mixin
                                            output-recording-stream)
  ((recording-p :initform t :reader stream-recording-p)
   (drawing-p :initform t :accessor stream-drawing-p)
   (output-history :initform (make-instance 'standard-tree-output-history)
                   :reader stream-output-history)
   (current-output-record :accessor stream-current-output-record)
   (current-text-output-record :initform nil
                               :accessor stream-current-text-output-record)
   (local-record-p :initform t
                   :documentation "This flag is used for dealing with streams outputting strings char-by-char.")
   ))

(in-package :clim-clx)

(defclass clx-port (basic-port)
  ((display :initform nil
	    :accessor clx-port-display)
   (screen :initform nil
	   :accessor clx-port-screen)
   (window :initform nil
	   :accessor clx-port-window)
   (color-table :initform (make-hash-table :test #'eq))
   (modifier-cache :initform nil
		   :accessor clx-port-modifier-cache)
   (design-cache :initform (make-hash-table :test #'eq))
   (pointer :reader port-pointer)
   ;;; New:
   (climi::selection-owner :initform nil)
   ))

(in-package :climi)

(defun blah ()
  (clim:destroy-port (clim:find-port))
  (cl-user::ab))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event pointer-button-press-event))
  (if (eql (event-modifier-state event) +shift-key+)
      (eos/shift-click pane event)
      (call-next-method)))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event pointer-button-release-event))
  (if (eql (event-modifier-state event) +shift-key+)
      (eos/shift-release pane event)
      (call-next-method)))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event pointer-motion-event))
  (with-slots (point-1-x dragging-p) pane
    (if (and (eql (event-modifier-state event) +shift-key+))
        (when dragging-p
          (eos/shift-drag pane event))
        (call-next-method))))

(defmethod eos/shift-click ((pane extended-output-stream) event)
  (with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane
    (cond ((eql +pointer-left-button+ (pointer-event-button event))
           ;; start dragging, set point-1 where the mouse is
           (setf point-1-x (pointer-event-x event))
           (setf point-1-y (pointer-event-y event))
           (setf dragging-p t))
          ((eql +pointer-middle-button+ (pointer-event-button event))
           ;; paste
           (xlib:convert-selection :primary :UTF8_STRING (sheet-direct-mirror pane) :bounce (event-timestamp event)))
          ((eql +pointer-right-button+ (pointer-event-button event))
           ;; If point-1 and point-2 are set up pick the nearest (what metric?) and drag it around.
           (when (< (+ (expt (- (pointer-event-x event) point-1-x) 2)
                       (expt (- (pointer-event-y event) point-1-y) 2))
                    (+ (expt (- (pointer-event-x event) point-2-x) 2)
                       (expt (- (pointer-event-y event) point-2-y) 2)))
             (rotatef point-1-x point-2-x)
             (rotatef point-1-y point-2-y))
           (eos/shift-drag pane event)
           (setf dragging-p t))
          (t
           (describe event))
          )))

(defmethod eos/shift-release ((pane extended-output-stream) event)
  event
  (with-slots (point-1-x point-1-y point-2-x point-2-y dragging-p) pane
    (when dragging-p
      (setf point-2-x (pointer-event-x event)
            point-2-y (pointer-event-y event)
            dragging-p nil)
      ;;
      (let ((owner (slot-value (port pane) 'selection-owner)))
        (when (and owner (not (eq owner pane)))
          (distribute-event (port pane)
                            (make-instance 'selection-clear-event
                                           :sheet owner
                                           :selection :primary))))
      (xlib:set-selection-owner
       (xlib:window-display (sheet-direct-mirror pane))
       :primary
       (sheet-direct-mirror pane))
      ;; ### check that we get it ...
      ;; ### timestamp
      (setf (slot-value (port pane) 'selection-owner) pane)
      ;;
      )))

(defmethod eos/shift-drag ((pane extended-output-stream) event)
  (with-slots (point-1-x point-1-y) pane
    (let ((old-markings (slot-value pane 'markings)))
      (setup-marked-extents pane (stream-output-history pane) +everywhere+
                            point-1-x point-1-y
                            (pointer-event-x event)
                            (pointer-event-y event))
      (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings)
                                :initial-value +nowhere+))
            (new-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) (slot-value pane 'markings))
                                :initial-value +nowhere+)))
        (handle-repaint pane (region-exclusive-or old-region new-region))))))

(defun map-over-text (record function)
  (cond ((typep record 'standard-text-displayed-output-record)
         (with-slots (strings baseline max-height start-y wrapped x1 y1) record
           (loop for substring in strings do
                 (with-slots (start-x string marked-extent text-style) substring
                   (funcall function start-x (+ start-y baseline) string text-style
                            substring record)))))
        (t
         (map-over-output-records-overlapping-region
          #'(lambda (x)
              (map-over-text x function))
          record +everywhere+))))

(defun setup-marked-extents (stream record region bx1 by1 bx2 by2)
  (cond ((> by1 by2)
         (rotatef by1 by2)
         (rotatef bx1 bx2))
        (t
         nil))
  (let ((*lines* nil)
        (*all-lines* nil))
    (map-over-text (stream-output-history stream)
                   (lambda (x y string ts record full-record)
                     (let ((q (assoc y *lines*)))
                       (unless q
                         (push (setf q (cons y nil)) *lines*))
                       (push (list x y string ts record full-record)
                             (cdr q)))
                     (finish-output *trace-output*)))
    (setf *lines*
          (sort (mapcar (lambda (line)
                          (cons (car line)
                                (sort (cdr line) #'< :key #'first)))
                        *lines*)
                #'< :key #'car))
    (setf *all-lines* *lines*)
    ;; Nuke every line that is above by1
    (setf *lines* (remove-if (lambda (line) (< (+ (car line) 3) by1)) *lines*))
    ;; Also nuke all that are below by2
    (setf *lines* (remove-if (lambda (line) (> (- (car line) 10) by2)) *lines*))
    ;; Special case:
    (when (= 1 (length *lines*))
      (psetf bx1 (min bx1 bx2)
             bx2 (max bx1 bx2)))
    ;; Then, in the first line find the index farthest to the right
    ;; which is still less than bx1.
    (let ((start-i 0)
          (start-record (fifth (cdar *lines*)))
          (end-i 0)
          end-record)

      ;; Then, in the first line find the index farthest to the right
      ;; which is still less than bx1.
      (loop for chunk in (cdr (first *lines*)) do
            (destructuring-bind (x y string ts record full-record) chunk
              (loop for i to (length string) do
                    (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
                             bx1)
                      (setf start-i i
                            start-record record)))))

      ;; Finally in the last line find  the index farthest to the left which still is greater than bx2.
      ;; Or put differently: Search from the left and while we are still in bounds maintain end-i and end-record.
      (loop for chunk in (cdr (car (last *lines*))) do
            (destructuring-bind (x y string ts record full-record) chunk
              (loop for i to (length string) do
                    (when (< (+ x (stream-string-width stream string :start 0 :end i :text-style ts))
                             bx2)
                      (setf end-i i
                            end-record record)))))
      ;; Now, humble grovel over the records, in order ...
      (let ((in-p nil)
            (marks nil))
        (labels ((visit (chunk)
                   (destructuring-bind (x y string ts record full-record) chunk
                     (let ((marked-extent nil))
                       (cond ((eq record start-record)
                              (cond ((eq record end-record)
                                     (setf marked-extent
                                           (cons start-i end-i)))
                                    (t
                                     (setf marked-extent
                                           (cons start-i (length string)))
                                     (setf in-p t))))
                             ((eq record end-record)
                              (setf marked-extent
                                    (cons 0 end-i))
                              (setf in-p nil))
                             (t
                              (setf marked-extent
                                    (if in-p
                                        (cons 0 (length string))
                                        nil))) )
                       (when marked-extent
                         (push (destructuring-bind (x y string ts record full-record) chunk
                                 (make-instance 'string-marking
                                                :record full-record
                                                :styled-string record
                                                :start (car marked-extent)
                                                :end (cdr marked-extent)))
                               marks)) ))))
          (loop for line in *all-lines* do
                (loop for chunk in (cdr line) do
                      (visit chunk)) )
          (setf (slot-value stream 'markings) (reverse marks)))))))


;;;; Selections Events

;; These events are probably very X11 specific.

(defclass selection-event (window-event)
  ((selection :initarg :selection
              :reader selection-event-selection) ))

(defclass selection-clear-event (selection-event)
  ())

(defclass selection-notify-event (selection-event)
  ((target   :initarg :target
             :reader selection-event-target)
   (property :initarg :property
             :reader selection-event-property)))

(defclass selection-request-event (selection-event)
  ((requestor :initarg :requestor
              :reader selection-event-requestor)
   (target    :initarg :target
              :reader selection-event-target)
   (property  :initarg :property
              :reader selection-event-property)))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event selection-clear-event))
  (with-slots (markings) pane
    (setf markings nil))
  (handle-repaint pane (sheet-region pane))
  (setf (slot-value (port pane) 'selection-owner) nil) )

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event selection-request-event))
  (warn "Selection request")
  (let ((requestor (selection-event-requestor event))
        (property  (selection-event-property event))
        (target    (selection-event-target event))
        (time      (event-timestamp event)))
    (describe event
              *trace-output*)
    (finish-output *trace-output*)
    (cond ((member target '(:UTF8_STRING :STRING :TEXT))
           (xlib:change-property requestor property
                                 (utf-8-encode
                                  (concatenate 'vector
                                               (map 'vector #'char-code "Hallöchen")
                                               (list #x20AC)
                                               (list #x2261)))
                                 :UTF8_STRING ;###
                                 8)            
           (xlib:send-event requestor
                            :selection-notify nil
                            :window requestor
                            :selection :primary
                            :target :UTF8_STRING;;target
                            :property property
                            :time time))
          ((member target '(:COMPOUND_TEXT))
           (xlib:change-property requestor property
                                 (vector 65 65 67
                                         #x1B #x24 #x29 #x41
                                         #xA1 #xD4
                                         67 65 67)
                                 :COMPOUND_TEXT
                                 8)            
           (xlib:send-event requestor
                            :selection-notify nil
                            :window requestor
                            :selection :primary
                            :target :COMPOUND_TEXT
                            :property property
                            :time time))
          (t
           (xlib:send-event requestor
                            :selection-notify nil
                            :window requestor
                            :selection :primary
                            :target :UTF8_STRING;;target
                            :property nil ;;property
                            :time time)))
    (xlib:display-force-output (xlib:window-display requestor))))

(defmethod clim:dispatch-event ((pane extended-output-stream)
                                (event selection-notify-event))
  (cond ((selection-event-property event)
         (let ((matter
                (map 'string #'code-char
                     (xlib:get-property (sheet-direct-mirror pane)
                                        (selection-event-property event)
                                        ;; :type :text
                                        :delete-p t
                                        :result-type 'vector))))
           (format *trace-output*
                   "Got ~S.~%"
                   matter)
           (loop for c across matter do
                 (dispatch-event pane
                                 (make-instance 'key-press-event
                                                :timestamp (event-timestamp event)
                                                :sheet pane
                                                :modifier-state 0
                                                :x 0 :y 0 :graft-x 0 :graft-y 0
                                                :key-name nil
                                                :key-character c)))
           ))
        (t
         (warn "Got nothing."))))

(defun fetch-selection (pane target)
  (let (old-y)
    (with-output-to-string (bag)
      ;; ###
      (with-slots (marks) pane
        (dolist (m marks)
          (destructuring-bind (x y string ts record) m
            (when (and old-y (> y old-y))
              (warn "terpri")
              (terpri bag))
            (setf old-y y)
            (princ (subseq string
                           (car (slot-value record 'marked-extent))
                           (cdr (slot-value record 'marked-extent)))
                   bag)))))))

(in-package :clim-clx)

(defun event-handler (&rest event-slots
                      &key display window event-key code state mode time
		      width height x y root-x root-y
		      data override-redirect-p send-event-p
		      hint-p type
                      target property requestor selection
                      &allow-other-keys)
  ;; NOTE: Although it might be tempting to compress (consolidate)
  ;; events here, this is the wrong place. In our current architecture
  ;; the process calling this function (the port's event handler
  ;; process) just reads the events from the X server, and does it
  ;; with almost no lack behind the reality. While the application
  ;; frame's event top level loop does the actual processing of events
  ;; and thus may produce lack. So the events have to be compressed in
  ;; the frame's event queue.
  ;;
  ;; So event compression is implemented in EVENT-QUEUE-APPEND.
  ;;
  ;; This changes for possible _real_ immediate repainting sheets,
  ;; here a possible solution for the port's event handler loop can be
  ;; to read all available events off into a temponary queue (and
  ;; event compression for immediate events is done there) and then
  ;; dispatch all events from there as usual.
  ;;
  ;;--GB
  
  ;; XXX :button code -> :button (decode-x-button-code code)
  (declare (ignorable event-slots))
  (declare (special *clx-port*))
  (let ((sheet (and window
		    (port-lookup-sheet *clx-port* window))))
    (when sheet
      (case event-key
	((:key-press :key-release)
         (multiple-value-bind (keyname modifier-state)
	     (x-event-to-key-name-and-modifiers *clx-port* 
						event-key code state)
           (make-instance (if (eq event-key :key-press)
			      'key-press-event
			      'key-release-event)
             :key-name keyname
	     :key-character (and (characterp keyname) keyname)
	     :x x :y y
	     :graft-x root-x
	     :graft-y root-y
             :sheet sheet :modifier-state modifier-state :timestamp time)))
	((:button-press :button-release)
	 (let ((modifier-state (x-event-state-modifiers *clx-port* state)))
	   (make-instance (if (eq event-key :button-press)
			      'pointer-button-press-event
			      'pointer-button-release-event)
			  :pointer 0
			  :button (decode-x-button-code code) :x x :y y
			  :graft-x root-x
			  :graft-y root-y
			  :sheet sheet :modifier-state modifier-state
			  :timestamp time)))
	(:enter-notify
	 (make-instance 'pointer-enter-event :pointer 0 :button code :x x :y y
                        :graft-x root-x
                        :graft-y root-y
			:sheet sheet
			:modifier-state (x-event-state-modifiers *clx-port*
								 state)
			:timestamp time))
	(:leave-notify
	 (make-instance (if (eq mode :ungrab)
			    'pointer-ungrab-event
			    'pointer-exit-event)
			:pointer 0 :button code
			:x x :y y
			:graft-x root-x
			:graft-y root-y
			:sheet sheet
			:modifier-state (x-event-state-modifiers *clx-port*
								 state)
			:timestamp time))
        ;;
	(:configure-notify
         ;; it would be nice to consolidate these for resizes, but because of the
         ;; interleaving exposures it becomes a bit tricky to do at this point. - BTS
         (cond ((and (eq (sheet-parent sheet) (graft sheet))
                     (not override-redirect-p)
                     (not send-event-p))
                ;; this is genuine event for a top-level sheet (with
                ;; override-redirect off)
                ;;
                ;; Since the root window is not our real parent, but
                ;; there the window managers decoration in between,
                ;; only the size is correct, so we need to deduce the
                ;; position from our idea of it.
                (multiple-value-bind (x y) (transform-position
                                            (compose-transformations
                                             (sheet-transformation sheet)
                                             (sheet-native-transformation (graft sheet)))
                                            0 0)
                  (make-instance 'window-configuration-event
                                 :sheet sheet
                                 :x x
                                 :y y
                                 :width width :height height)))
               (t
                ;; nothing special here
                (make-instance 'window-configuration-event
                               :sheet sheet
                               :x x :y y :width width :height height))))
	(:destroy-notify
	 (make-instance 'window-destroy-event :sheet sheet))
	(:motion-notify
	 (let ((modifier-state (x-event-state-modifiers *clx-port*
							state)))
	   (if hint-p
	       (multiple-value-bind (x y same-screen-p child mask
				     root-x root-y)
		   (xlib:query-pointer window)
		 (declare (ignore mask))
		 ;; If not same-screen-p or the child is different
		 ;; from the original event, assume we're way out of date
		 ;; and don't return an event.
		 (when (and same-screen-p (not child))
		   (make-instance 'pointer-motion-hint-event
				  :pointer 0 :button code
				  :x x :y y
				  :graft-x root-x :graft-y root-y
				  :sheet sheet
				  :modifier-state modifier-state
				  :timestamp time)))
	       (progn
		 (make-instance 'pointer-motion-event
				:pointer 0 :button code
				:x x :y y
				:graft-x root-x
				:graft-y root-y
				:sheet sheet
				:modifier-state modifier-state
				:timestamp time)))))
        ;;
	((:exposure :display)
         ;; Notes:
         ;; . Do not compare count with 0 here, last rectangle in an
         ;;   :exposure event sequence does not cover the whole region. 
         ;;
         ;; . Do not transform the event region here, since
         ;;   WINDOW-EVENT-REGION does it already. And rightfully so. 
         ;;   (think about changing a sheet's native transformation).
         ;;--GB
         ;;
         ;; Mike says:
         ;;   One of the lisps is bogusly sending a :display event instead of an
         ;; :exposure event. I don't remember if it's CMUCL or SBCL. So the
         ;; :display event should be left in.
         ;;
         (make-instance 'window-repaint-event
           :timestamp time
           :sheet sheet
           :region (make-rectangle* x y (+ x width) (+ y height))) )
        ;;
        (:selection-notify
         (make-instance 'climi::selection-notify-event
          :sheet sheet
          :selection selection
          :target target
          :property property))
        (:selection-clear
         (make-instance 'climi::selection-clear-event
          :sheet sheet
          :selection selection))
        (:selection-request
         (make-instance 'climi::selection-request-event
          :sheet sheet
          :selection selection
          :requestor requestor
          :target target
          :property property
          :timestamp time))
	(:client-message
         (port-client-message sheet time type data))
	(t
	 nil)))))

(defmethod port-client-message (sheet time (type (eql :wm_protocols)) data)
  (port-wm-protocols-message sheet time
                             (xlib:atom-name (slot-value *clx-port* 'display) (aref data 0))
                             data))

(defmethod port-client-message (sheet time (type t) data)
  (warn "Unprocessed client message: ~:_type = ~S;~:_ data = ~S;~_ sheet = ~S."
        type data sheet))

(defmethod port-wm-protocols-message (sheet time (message (eql :wm_delete_window)) data)
  (declare (ignore data))
  (make-instance 'window-manager-delete-event
                 :sheet sheet
                 :timestamp time))

(defmethod port-wm-protocols-message (sheet time (message t) data)
  (warn "Unprocessed WM Protocols message: ~:_message = ~S;~:_ data = ~S;~_ sheet = ~S."
        message data sheet))


;;;; Interaction to implement:

;; Mouse-L down: set the first point
;; Mouse-L drag: drag the second point
;; Mouse-L up:   set the second point

;; Mouse-L single click: (maybe) select current presentation, if any.
;; Mouse-L double click: select word
;; Mouse-L triple click: select "line".

;; Mouse-R down: pick the nearest point, if any
;; Mouse-R drag: drag said point
;; Mouse-R up:   leave said point where it was dragged to.

;; Mouse-M:      paste

;;;; Conversions

;; we at least want to support:

;; :TEXT, :STRING
;;
;; :UTF8_STRING
;;     As seen from xterm [make that the prefered encoding]
;;
;; :COMPOUND_TEXT
;;    Perhaps relatively easy to produce, hard to grok.
;;


(defun utf-8-encode (code-points)
  (let ((res (make-array (length code-points)
                         :adjustable t
                         :fill-pointer 0)))
    (map 'nil
         (lambda (code-point)
           (cond ((< code-point (expt 2 7))
                  (vector-push-extend code-point res))
                 ((< code-point (expt 2 11))
                  (vector-push-extend (logior #b11000000 (ldb (byte 5 6) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res))
                 ((< code-point (expt 2 16))
                  (vector-push-extend (logior #b11100000 (ldb (byte 4 12) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res))
                 ((< code-point (1- (expt 2 21)))
                  (vector-push-extend (logior #b11110000 (ldb (byte 3 18) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 12) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res))
                 ((< code-point (1- (expt 2 26)))
                  (vector-push-extend (logior #b11110000 (ldb (byte 2 24) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 18) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 12) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res))
                 ((< code-point (1- (expt 2 31)))
                  (vector-push-extend (logior #b11110000 (ldb (byte 1 30) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 24) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 18) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 12) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 6) code-point)) res)
                  (vector-push-extend (logior #b10000000 (ldb (byte 6 0) code-point)) res))
                 (t
                  (error "Bad code point: ~D." code-point))))
         code-points)
    res))

(defmethod climi::bounding-rectangle* ((x (eql +nowhere+)))
  (values 0 0 0 0))