glrepl-main.lisp

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