glrepl-tests.lisp

   1
   2
   3 (in-package :glrepl)
   4
   5 ;;  (- (win-width-of win)) (* 2 (win-height-of win))
   6 ;;                (* 2 (win-width-of win)) (- (* 2 (win-height-of win)))))
   7
   8 (defvar *esc-pressed* nil)
   9
  10 (defparameter *glwindow* nil)
  11
  12 (defparameter *console* t)
  13 ;; gives us unicode keys
  14 ;; (cffi:defcallback char-callback :void ((key :int) (action :int))
  15 ;;   )
  16
  17
  18 ;; evaluate a form, echo result to console: somewhat stolen
  19 ;; from perfectstorm..
  20 (defun console-eval (s)
  21   "Evauluate s and return the output as a string"
  22   (let ((eval-result
  23          (format nil "~a"
  24                  (handler-case (multiple-value-list
  25                                 (eval (read (make-string-input-stream s))))
  26                    (error (e)
  27                      (format nil "~a" e))))))
  28     eval-result))
  29
  30 (cffi:defcallback char-callback :void ((key :int) (action :int))
  31   ;; (format t "Char ~A " key)
  32   (when (and *console* (= action glfw:+press+))
  33     (let ((c (code-char key)))
  34       (when c
  35         (add-char *glwindow* (code-char key))))))
  36
  37
  38 (cffi:defcallback key-callback :void ((key :int) (action :int))
  39   ;; (format t "Keypress ~A " key)
  40   (when (= action glfw:+press+)
  41     ;; f10 toggles console
  42     (when (= key glfw:+key-f10+)
  43       (setf *console* (not *console*)))
  44     ;; esc quits
  45     (when
  46         (= key glfw:+key-esc+)  (setf *esc-pressed* t))
  47     (when *console*
  48       (cond
  49         ;;       ;; backspace removes previous char
  50         ((= key glfw:+key-backspace+) (del-char-left *glwindow*))
  51         ;;       ;; del removes next char
  52         ((= key glfw:+key-del+) (del-char-right *glwindow*))
  53         ((= key glfw:+key-f5+)  (progn
  54                                   (setf (current-result-line *glwindow*)
  55                                         (console-eval (current-line-as-string *glwindow*)))
  56                                   (add-to-history *glwindow* (current-line-as-string *glwindow*))))
  57         ;; arrows move cursor
  58         ((= key glfw:+key-left+) (cursor-left *glwindow*))
  59         ((= key glfw:+key-right+) (cursor-right *glwindow*))
  60
  61         ;; up down through history
  62         ((= key glfw:+key-up+ (setf (current-line *glwindow*) (previous-history *glwindow*)))
  63         ((= key glfw:+key-down+ (setf (current-line *glwindow*) (next-history *glwindow*)))
  64
  65         ((= key glfw:+key-f6+) (setf (current-result-line *glwindow*) "Repl Result"))
  66         ))))
  67
  68
  69
  70 ;;       ;; TO DO
  71 ;;       ;; page up, page down, skip sexps
  72
  73
  74 ;;       ;; return inserts newline
  75 ;;       ;; f5 evaluates -- TO DO -- sort this out
  76
  77
  78 (cffi:defcallback window-size-callback :void ((width :int) (height :int))
  79   (setf (win-width-of *glwindow*) width)
  80   (setf (win-height-of *glwindow*) height)
  81   (viewport *glwindow*))
  82
  83
  84 (defun init-gl ()
  85   (gl:enable gl:+texture-2d+)
  86   (gl:matrix-mode gl:+projection+)
  87   (gl:load-identity)
  88   (gl:push-matrix)
  89   (gl:matrix-mode gl:+modelview+)
  90   (gl:load-identity)
  91   (gl:push-matrix)
  92   (viewport *glwindow*))
  93
  94 (defun end-gl ()
  95   ())
  96
  97 (defun callback-set ()
  98   (setf *esc-pressed* nil)
  99   (glfw:set-key-callback (cffi:callback key-callback))
 100   (glfw:set-char-callback (cffi:callback char-callback)))
 101
 102 (defun callback-clear ()
 103   (glfw:set-key-callback (cffi:null-pointer))
 104   (glfw:set-char-callback (cffi:null-pointer)))
 105
 106 (defun render-char (font c x y)
 107   (when (graphic-char-p c)
 108     (let ((image (aref (glrepl::images-of font) (char-code c))))
 109       (when (typep  image 'rgba-image) ;; couldn't this simply be when?
 110         (with-opengl
 111           (gl:bind-texture gl:+texture-2d+
 112                            (cffi::mem-ref (name-of image) :uint32))
 113           (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+replace+) ;; maybe +decal+?
 114           (gl:color-4f 0.0 0.0 0.0 1.0)
 115           (gl:enable gl:+texture-2d+)
 116           (gl:enable gl:+blend+)
 117           (gl:blend-func gl:+src-alpha+ gl:+one-minus-src-alpha+)
 118           (let ((texture-height (texture-height-of *glwindow*))
 119                 (texture-width (texture-width-of *glwindow*)))
 120             (gl:with-begin gl:+quads+
 121               (gl:tex-coord-2i 0 1)
 122               (gl:vertex-2f x y) ;; top lhs
 123               (gl:tex-coord-2i 1 1)
 124               (gl:vertex-2f  (+ x texture-width) y  ) ;; top rhs
 125               (gl:tex-coord-2f 1 0)
 126               (gl:vertex-2f  (+ x texture-width) (+ y texture-height)) ;; bot rhs
 127               (gl:tex-coord-2i 0 0)
 128               (gl:vertex-2f x (+ y texture-height))))))))) ;; bot lhs
 129
 130 (defun render-cursor (font x y)
 131   (let ((image (aref (glrepl::images-of font) (char-code #\_))))
 132       (when (typep  image 'rgba-image)
 133         (with-opengl
 134           (gl:bind-texture gl:+texture-2d+
 135                            (cffi::mem-ref (name-of image) :uint32))
 136           (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+replace+) ;; maybe +decal+?
 137           (gl:color-4f 0.0 0.0 0.0 1.0)
 138           (gl:enable gl:+texture-2d+)
 139           (gl:enable gl:+blend+)
 140           (gl:blend-func gl:+one+ gl:+one+)
 141           (let ((texture-height (texture-height-of *glwindow*))
 142                 (texture-width (texture-width-of *glwindow*)))
 143             (gl:with-begin gl:+quads+
 144               (gl:tex-coord-2i 0 1)
 145               (gl:vertex-2f x y) ;; top lhs
 146               (gl:tex-coord-2i 1 1)
 147               (gl:vertex-2f  (+ x texture-width) y  ) ;; top rhs
 148               (gl:tex-coord-2f 1 0)
 149               (gl:vertex-2f  (+ x texture-width) (+ y texture-height)) ;; bot rhs
 150               (gl:tex-coord-2i 0 0)
 151               (gl:vertex-2f x (+ y texture-height)))))))) ;; bot lhs
 152
 153 ;; (defun render-world ()
 154 ;;   (multiple-value-bind
 155 ;;         (px py)
 156 ;;       (window-pixel-atxy *glwindow* 0 0)
 157 ;;   (render-char (font-of *glwindow*) #\A px py)))
 158
 159 (defun render-world ()
 160   (when *console*
 161     (let* ((rendered-chain (current-line *glwindow*))
 162            (screen-line 0)
 163            (screen-column 0)
 164            (current-chain-offset 0)
 165            (char-to-render #\Nul)
 166            (cursor (make-instance 'flexichain:left-sticky-flexicursor :position 0 :chain rendered-chain)))
 167       (iterate
 168         ;; while there is still a line to render
 169         (while (and (not (null cursor)) (< screen-line (text-height-of *glwindow*))))
 170         (iterate
 171           (while (not (flexichain:at-end-p cursor)))
 172           (setf char-to-render (flexichain:element> cursor))
 173           (multiple-value-bind  (pixel-x pixel-y)
 174               (window-pixel-atxy *glwindow* screen-column screen-line)
 175             (when (graphic-char-p char-to-render)
 176               ;; actually draw our char
 177               (render-char (font-of *glwindow*) char-to-render pixel-x pixel-y)
 178               (when (and (zerop current-chain-offset)
 179                          (= (flexichain:cursor-pos cursor) (flexichain:cursor-pos (current-cursor *glwindow*))))
 180                 (render-cursor (font-of *glwindow* pixel-x pixel-y)))
 181               ;; advance cursor to next screen colum
 182               (incf screen-column)
 183               ;; word wrap if off ed
 184               (when (>= screen-column (text-width-of *glwindow*))
 185                 (setf screen-column 0)
 186                 (incf screen-line)))
 187             (when (char= #\Newline char-to-render)
 188               (setf screen-column 0)
 189               (incf screen-line)))
 190           (incf (flexichain:cursor-pos cursor)))
 191         ;; ran out of this line, bump onto next
 192         (incf screen-line)
 193         (setf screen-column 0)
 194         (incf current-chain-offset)
 195         (setf cursor nil)
 196         (setf rendered-chain nil)
 197         (let ((current-chain-index (+ (cursor-line-of *glwindow*) current-chain-offset)))
 198           (when (< current-chain-index (length (lines-of *glwindow*)))
 199             (setf rendered-chain (chain-of (aref (lines-of *glwindow*) current-chain-index)))
 200             (setf cursor (make-instance 'flexichain:left-sticky-flexicursor :position 0 :chain rendered-chain))))))))
 201
 202
 203 ;;  (render-char (font-of window) #\A 0.5 0.5))
 204
 205 (defun update-world (dt))
 206
 207 (defun main-loop ()
 208   (let ((t0 (glfw:get-time))
 209         (dt 0.0)
 210         (test-image (make-instance 'glrepl::rgba-image :width 64 :height 64)))
 211     (iterate
 212       (for i from 0 below (* 64 64))
 213       (setf (glrepl::pixel test-image i) #X000000FF))
 214     (glrepl::update-image test-image)
 215     (glfw:sleep 0.05d0)
 216     (gl:clear-color 0.0 0.0 0.0 1.0)
 217     (iterate
 218       (while (= (glfw::get-window-param glfw:+opened+) glfw:+true+))
 219       (gl:clear gl:+color-buffer-bit+)
 220       (setf dt (- (glfw:get-time) t0))
 221       (setf t0 (glfw:get-time))
 222       (update-world dt)
 223       (render-world)
 224       ;;(glrepl::render  test-image)
 225       ;; update
 226       ;; check for time available if time is avaliable render
 227       ;; surrender any cpu time..
 228       (glfw:swap-buffers)
 229       (if *esc-pressed*
 230           (glfw:close-window)))))
 231
 232 (defun glrepl ()
 233   (if (glfw::init)
 234       (progn
 235         (setf *glwindow* (make-instance 'glrepl-window))
 236         (add-line *glwindow*)
 237         (add-line *glwindow*)
 238         (add-string *glwindow* "Hello World")
 239         (if (glfw:open-window (win-width-of *glwindow*) (win-height-of *glwindow*) 16 16 16 16 16)
 240             (progn
 241               (init-gl)
 242               (format t "Making font..")
 243               (setf (font-of *glwindow*) (make-font glrepl::*font-pathname*)) ;; prbly shld be mber of window
 244               (format t "Done..")
 245               (glfw:swap-interval 1)
 246               (glfw:enable glfw:+key-repeat+)
 247               (callback-set)
 248               ;;                (glrepl::dump (aref *font-images* 65))
 249               (main-loop)
 250               (callback-clear)
 251               (end-gl)
 252               (glfw:terminate))
 253             (error "Failed to open window")))
 254       (error "Failed to init glfw")))
 255
 256 ;; (defun test-glrepl ()
 257 ;;   (glfw:with-init-window ("Glrepl" *win-width* *win-height*)
 258 ;;     (glfw:set-window-size-callback (cffi:callback window-size-callback))
 259 ;;     (glfw:set-key-callback (cffi:callback key-callback))
 260 ;;     (glfw:swap-interval 1)
 261 ;;     (let* ((frame 0))
 262 ;;       (iterate
 263 ;;         (while (and (not *esc-pressed*)
 264 ;;                     (eql (glfw:get-window-param glfw:+opened+) gl:+true+)))
 265 ;;         (gl:clear gl:+color-buffer-bit+)
 266 ;;         (incf frame)
 267 ;;         (glfw:swap-buffers)
 268 ;;           (cl:sleep 0.1))
 269 ;;       (if (eql (glfw:get-window-param glfw:+opened+) gl:+true+)
 270 ;;         (glfw:close-window))
 271 ;;       (glfw:terminate))))
 272
 273 ;; (setf *glwindow* (make-instance 'glrepl-window))
 274 ;; (make-instance 'glrepl-window-line)
 275
 276 ;; (add-line *glwindow*)
 277 ;; (add-string *glwindow* "Hello World")
 278
 279 ;;(test-glrepl)