;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: VNC; -*-
;;; ---------------------------------------------------------------------------
;;;     Title: A Simple Lisp VNC Server
;;;   Created: 2002-07-31
;;;    Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
;;; ---------------------------------------------------------------------------
;;;  (c) copyright 2002 by Gilbert Baumann

;; (run)
;; vncviewer localhost:15

(eval-when (compile eval load)          ;grff
  (require :clim)
  (require :glisp))

(defpackage :vnc
    (:use :clim-lisp))

(in-package :vnc)

;; CMUCL likes it if the DEFCLASS comes early

(defclass font ()
  ((ascent  :initarg :ascent  :reader font-ascent)
   (descent :initarg :descent :reader font-descent)
   (glyphs  :initarg :glyphs  :reader font-glyphs)))

(defclass glyph ()
  ((width   :initarg :width   :reader glyph-width)
   (ascent  :initarg :ascent  :reader glyph-ascent)
   (descent :initarg :descent :reader glyph-descent)
   (image   :initarg :image   :reader glyph-image)))

(defconstant +port-base+ 5900)

(defun start-vnc-listener (&key (display-number 15))
  (clim-sys:make-process
   (lambda ()
     (let ((socket (glisp:make-server-socket (+ +port-base+ display-number) :element-type '(unsigned-byte 8))))
       (loop
           (let ((io (glisp::accept-connection/low socket)))
             (clim-sys:make-process (lambda ()
                                      (with-open-stream (io io)
                                        (vnc-server io))
                                      :name "VNC Session"))))))
   :name "VNC Listener"))

;;;

(defun read-card8 (input-stream)
  (read-byte input-stream))

(defun read-card16 (input-stream)
  (dpb (read-byte input-stream) (byte 8 8)
       (dpb (read-byte input-stream) (byte 8 0)
            0)))

(defun read-card32 (input-stream)
  (dpb (read-card16 input-stream) (byte 16 16)
       (dpb (read-card16 input-stream) (byte 16 0)
            0)))

(defun read-boolean (input-stream)
  (not (zerop (read-card8 input-stream))))

(defun read-padding (n input-stream)
  (loop repeat n do (read-byte input-stream)))

(defmacro read-* (n subtype input-stream)
  (let ((res (gensym "RES."))
        (i   (gensym "I.")))
    `(let ((,res (make-array ,n)))
      (dotimes (,i (length ,res))
        (setf (aref ,res ,i) ,(reader-code subtype input-stream)))
      ,res)))

(defmacro read-** (length-subtype subtype input-stream)
  (let ((res (gensym "RES."))
        (i   (gensym "I."))
        (n   (gensym "N.")))
    `(let* ((,n ,(reader-code length-subtype `,input-stream))
            (,res (make-array ,n)))
      (dotimes (,i ,n)
        (setf (aref ,res ,i) ,(reader-code subtype input-stream)))
      ,res)))

(defun read-ascii-char (input-stream)
  (code-char (read-card8 input-stream)))

;;;

(defun write-card8 (object output)
  (write-byte object output))

(defun write-card16 (object output)
  (write-card8 (ldb (byte 8 8) object) output)
  (write-card8 (ldb (byte 8 0) object) output))

(defun write-card32 (object output)
  (write-card16 (ldb (byte 16 16) object) output)
  (write-card16 (ldb (byte 16 0) object) output))

(defun write-boolean (object output)
  (write-card8 (if object 1 0) output))

(defun write-padding (n object output)
  (declare (ignore object))
  (loop repeat n do (write-byte 0 output)))

(defun write-ascii-char (object output)
  (write-card8 (char-code object) output))

(defmacro write-* (n subtype object output)
  (let ((obj (gensym "OBJ."))
        (i   (gensym "I.")))
    `(let ((,obj ,object))
      (dotimes (,i (length ,obj))
        ,(writer-code subtype `(aref ,obj ,i) output)))))

(defmacro write-** (length-subtype subtype object output)
  (let ((obj (gensym "OBJ."))
        (i   (gensym "I.")))
    `(let ((,obj ,object))
      ,(writer-code length-subtype `(length ,obj) `,output)
      (dotimes (,i (length ,obj))
        ,(writer-code subtype `(aref ,obj ,i) output)))))

;;;

(eval-when (eval compile load)
  (defun reader-name (sym)
    (intern (format nil "READ-~A" (symbol-name sym))))

  (defun writer-name (sym)
    (intern (format nil "WRITE-~A" (symbol-name sym))))

  (defun reader-code (type io)
    (cond ((symbolp type)
           (reader-code (list type) io))
          (t
           `(,(reader-name (car type))
             ,@(cdr type)
             ,io))))

  (defun writer-code (type thing io)
    (cond ((symbolp type)
           (writer-code (list type) thing io))
          (t
           `(,(writer-name (car type))
             ,@(cdr type)
             ,thing
             ,io)))))

(defmacro define-binary-struct (name slots)
  (let ((object (gensym "OBJECT."))
        (output (gensym "OUTPUT.")))
    `(progn
      ;;
      (defclass ,name ()
        ,(mapcan (lambda (slot)
                   (if (null (first slot))
                       nil
                       (list
                        (list (first slot)
                              :reader  (intern (format nil "~A-~A" (symbol-name name) (symbol-name (first slot))))
                              :initarg (intern (symbol-name (first slot)) (find-package :keyword))))))
                 slots))
      ;;
      (defmethod print-object ((object ,name) stream)
        (print-unreadable-object (object stream :type t :identity nil)
          (let ((f nil))
            (dolist (k ',(remove nil (mapcar #'first slots)))
              (when (slot-boundp object k)
                (format stream "~A~S ~S~:_"
                        (if f " " (setf f ""))
                        (intern (symbol-name k) (find-package :keyword))
                        (slot-value object k)))))))
      ;;
      (defun ,(reader-name name) (input)
        (let ((res (make-instance ',name)))
          (with-slots ,(remove nil (mapcar #'first slots)) res
            ,@(mapcar (lambda (slot)
                        (if (null (first slot))
                            (reader-code (second slot) 'input)
                            `(setf ,(first slot) ,(reader-code (second slot) 'input))))
                      slots))
          res))
      (defun ,(writer-name name) (,object ,output)
        (with-slots ,(remove nil (mapcar #'first slots)) ,object
          ,@(mapcar (lambda (slot)
                      (if (null (first slot))
                          (writer-code (second slot) nil `,output)
                          (writer-code (second slot) (first slot) `,output)))
                    slots)))
      ',name)))

(defmacro define-message (name id slots)
  `(progn
    (define-binary-struct ,name ,slots)
    (defmethod read-message-by-first-octet ((code (eql ,id)) input)
      ,(reader-code name 'input))
    ',name))

(defun read-message (input)
  (let ((x (read-byte input nil :eof)))
    (if (eq x :eof)
        x
        (read-message-by-first-octet x input))))

;;;;

(define-binary-struct pixel-format
  ((bits-per-pixel card8)
   (depth          card8)
   (big-endian-p   boolean)
   (true-color-p   boolean)
   (red-max        card16)
   (green-max      card16)
   (blue-max       card16)
   (red-shift      card8)
   (green-shift    card8)
   (blue-shift     card8)
   (nil            (padding 3))))

(define-binary-struct server-initialization-message
  ((framebuffer-width card16)
   (framebuffer-height card16)
   (pixel-format       pixel-format)
   (name-string        (** card32 ascii-char))))

(define-message set-pixel-format 0
  ((nil          (padding 3))
   (pixel-format pixel-format)))

(define-message fix-color-map-entries 1
  ((nil         (padding 1))
   (first-color card16)
   (n           card16)
   (colors      (* (* 3 n) card16))))

(define-message set-encoding-message 2
  ((nil         (padding 1))
   (encodings   (** card16 card32))))

(define-message framebuffer-update-request 3
  ((incremental-p boolean)
   (x             card16)
   (y             card16)
   (width         card16)
   (height        card16)))

(define-message key-event 4
  ((down-p        boolean)
   (nil           (padding 2))
   (key           card32)))

(define-message pointer-event 5
  ((button-mask   card8)
   (x             card16)
   (y             card16)))

(define-message client-cut-text 6
  ((nil           (padding 3))
   (text          (** card32 ascii-char))))

;;
;; We want to support multiple connections to the same frame buffer,
;; so the dirty list must be a property of the connection and not of
;; the frame buffer itself. The only question, which arises is how to
;; distribute the dirty regions to the per-connection queue?
;;

(defun vnc-server (io &aux f)
  (let ((*package* (find-package :vnc))
        (wants-update-p nil))           ;whether the client wants an update.
    ;;
    (write-sequence (map 'vector #'char-code "RFB 003.003") io)
    (write-sequence #(#x0a) io)
    (finish-output io)
    (print
     (with-output-to-string (bag)
       (do ((c (read-byte io nil #x0a) (read-byte io nil #x0a)))
           ((= c #x0a))
         (princ (code-char c) bag))))
    (finish-output)
    ;; auth
    (write-sequence #(0 0 0 1) io)
    (finish-output io)
    (let ((buf (make-array 1)))
      (read-sequence buf io)
      (print `(shared = ,buf)))
    (finish-output)
    (write-server-initialization-message
     (make-instance 'server-initialization-message
                    :framebuffer-width  (array-dimension (slot-value *the-frame-buffer* 'pixels) 1)
                    :framebuffer-height (array-dimension (slot-value *the-frame-buffer* 'pixels) 0)
                    :pixel-format
                    (make-instance 'pixel-format
                                   :bits-per-pixel 24
                                   :depth          24
                                   :big-endian-p   t
                                   :true-color-p   t
                                   :red-max        255   :red-shift 0
                                   :green-max      255   :green-shift 0
                                   :blue-max       255   :blue-shift 0)
                    :name-string "Lucky Lisp VNC Server")
     io)
    (finish-output io)

    (loop
        ;; wait for something to happen
        ;;clim-sys:process-wait "waiting for input"
        (do ()
            ((or (listen io)
                 (not (eq (slot-value *the-frame-buffer* 'dirty) clim:+nowhere+))))
          (mp:process-yield))

        (when (listen io)
          (let ((msg (read-message io)))
            (cond ((eql msg :eof)
                   (return)))
            (typecase msg
              (framebuffer-update-request
               (with-slots (incremental-p x y width height) msg
                 (cond (incremental-p
                        ;; we assume that
                        )
                       ((not incremental-p)
                        (frame-buffer-dirty-rectangle *the-frame-buffer*
                                                      x y (+ x (1- width)) (+ y (1- height))))))))))

      (when (not (eq (slot-value *the-frame-buffer* 'dirty) clim:+nowhere+))
          (send-update io)))))

(defun send-update (io)
  (let ((pixarray (slot-value *the-frame-buffer* 'pixels)))
    (clim:map-over-region-set-regions
     (lambda (r)
       (clim:with-bounding-rectangle* (x1 y1 x2 y2) r
        (setf x1 (floor x1))
        (setf y1 (floor y1))
        (setf x2 (floor x2))
        (setf y2 (floor y2))
        ;;(incf x2)
        ;;(incf y2)
        (write-sequence
         (vector 0 0                    ;type and padding
          0 1                           ;number of rects
          (ldb (byte 8 8) x1) (ldb (byte 8 0) x1)
          (ldb (byte 8 8) y1) (ldb (byte 8 0) y1)
          (ldb (byte 8 8) (- x2 x1)) (ldb (byte 8 0) (- x2 x1))
          (ldb (byte 8 8) (- y2 y1)) (ldb (byte 8 0) (- y2 y1))
          0 0 0 0)                      ;encoding
         io)
        (let ((buffer (make-array (* (- x2 x1) (- y2 y1) 4)
                                  :element-type '(unsigned-byte 8)))
              (j 0))
          (declare (optimize (speed 3) (safety 0))
                   (type fixnum j)
                   (type (simple-array (unsigned-byte 8) (*)) buffer)
                   (type (simple-array t (* *)) pixarray))
          ;;
          (loop for y fixnum from y1 below y2 do
                (loop for x fixnum from x1 below x2 do
                      (let ((p (aref pixarray y x)))
                        (declare (type (unsigned-byte 24) p))
                        (setf (aref buffer j) (ldb (byte 8 0) p))
                        (setf j (the fixnum (+ j 1)))
                        (setf (aref buffer j) (ldb (byte 8 8) p))
                        (setf j (the fixnum (+ j 1)))
                        (setf (aref buffer j) (ldb (byte 8 16) p))
                        (setf j (the fixnum (+ j 1)))
                        (setf (aref buffer j) 0)
                        (setf j (the fixnum (+ j 1))))))
          (write-sequence buffer io)
          )))
     (slot-value *the-frame-buffer* 'dirty))
    (setf (slot-value *the-frame-buffer* 'dirty) clim:+nowhere+)
    (finish-output io)))

;;; ------------------------------------------------------------------------------------------
;;;  The Frame Buffer itself

(defvar *the-frame-buffer*)

(defclass frame-buffer ()
  ((pixels :initarg :pixels
           :initform (make-array (list 600 600) :initial-element 0))
   (dirty  :initform clim:+nowhere+)
   ))

(defmethod frame-buffer-dirty-rectangle ((fb frame-buffer) x1 y1 x2 y2)
  (with-slots (dirty) fb
    (setf dirty (clim:region-union dirty (clim:make-rectangle* x1 y1 x2 y2)))))

(defun fb/draw-rectangle (x1 y1 x2 y2 color &optional (fb *the-frame-buffer*))
  (let ((pixarray (slot-value fb 'pixels)))
    (setf x1 (max 0 (min (1- (array-dimension pixarray 1)) x1)))
    (setf x2 (max 0 (min (1- (array-dimension pixarray 1)) x2)))
    (setf y1 (max 0 (min (1- (array-dimension pixarray 0)) y1)))
    (setf y2 (max 0 (min (1- (array-dimension pixarray 0)) y2)))
    (when (and (< x1 x2) (< y1 y2))
      (locally
          (declare (type (simple-array t (* *)) pixarray)
                   (optimize (speed 3) (safety 0)))
        (loop for y of-type (unsigned-byte 16) from y1 below y2 do
              (loop for x of-type (unsigned-byte 16) from x1 below x2 do
                    (setf (aref pixarray y x) color)))))
    (frame-buffer-dirty-rectangle fb x1 y1 x2 y2)))

(defmethod fb/draw-glyph ((glyph glyph) x y color &optional (fb *the-frame-buffer*))
  (let ((pixarray   (slot-value fb 'pixels))
        (glyph-image (glyph-image glyph)))
    (decf y (glyph-ascent glyph))
    (loop for gy from 0 below (array-dimension glyph-image 0) do
          (loop for gx from 0 below (array-dimension glyph-image 1) do
                (unless (zerop (aref glyph-image gy gx))
                  (setf (aref pixarray (+ y gy) (+ x gx)) color))))
    (frame-buffer-dirty-rectangle fb x y
                                  (+ x (array-dimension glyph-image 1))
                                  (+ y (array-dimension glyph-image 0)))))

(defmethod fb/draw-text ((font font) text x y color &optional (fb *the-frame-buffer*))
  (loop for c across text do
        (let ((c (char-code c)))
          (fb/draw-glyph (aref (font-glyphs font) c) x y color fb)
          (incf x (glyph-width (aref (font-glyphs font) c))))))



;;; code to steal a font.

(defvar *afont*)


(defun borrow-font (font-name &key (host "") (display 0))
  (let* ((display (xlib:open-display host :display display))
         (font    (xlib:open-font display font-name))
         (bm      (xlib:create-pixmap :width 128
                   :height 128
                   :depth 1
                   :drawable (xlib:screen-root (first (xlib:display-roots display)))))
         (gc      (xlib:create-gcontext :drawable bm :foreground 1 :background 0
                                        :font font)))
    (prog1
        (let ((res (make-instance 'font
                                  :ascent (xlib:font-ascent font)
                                  :descent (xlib:font-descent font)
                                  :glyphs (make-array 256))))
          (dotimes (c 256)
            (xlib:draw-image-glyph bm gc 0 (xlib:char-ascent font c) c)
            (let* ((w (xlib:char-width font c))
                   (h (+ (xlib:char-ascent font c) (xlib:char-descent font c)))
                   (data (make-array (list h w) :element-type 'bit)))
              (xlib:get-image
               bm :x 0 :y 0 :width w :data data :height h
               :format :z-pixmap :result-type 'xlib:image-z)
              (setf (aref (slot-value res 'glyphs) c)
              (make-instance 'glyph
                             :width w
                             :ascent (xlib:char-ascent font c)
                             :descent (xlib:char-descent font c)
                             :image data))))
          res)
      (xlib:close-display display))))

;;;

(defun init ()
  (fb/draw-rectangle 0 0
                     (1- (array-dimension (slot-value *the-frame-buffer* 'pixels) 1))
                     (1- (array-dimension (slot-value *the-frame-buffer* 'pixels) 0))
                     #xaabbcc)
  (fb/draw-rectangle 50 80
                     550 550
                     #xffffff)
  (let ((font (borrow-font "-*-lucida-medium-r-*-*-*-120-*-*-*-*-iso8859-1")))
    (fb/draw-text (borrow-font "-*-lucida-bold-r-*-*-*-140-*-*-*-*-iso8859-1")
                  "Welcome to the Sketch Server." 5 20 #x000000)
    (fb/draw-text font "To make marks simply drag with Mouse-L." 5 40 #x000000)
    (fb/draw-text font "To type text, simply start typing." 5 60 #x000000)))

(defun run ()
  (start-vnc-listener)
  (setf *the-frame-buffer* (make-instance 'frame-buffer))
  (init))