source: project/gl-display-glx/samples/s03-repl.scm @ 3309

#! /bin/sh
#|
exec csi -s $0 "$@"
|#

(require-extension gl-display-glx)
(require-extension gl-font)
(require 'gl-display-events-util)
(require 'gl-display-event-queue)
(require 'gl-util)
(require 'gl-proj)


(define *display* (gl-display:create 'width 400 'height 400))
(gl-font:create-from-path "/usr/share/fonts/truetype/ttf-dejavu/DejaVuSansMono.ttf")
(gl-util:initialize)
(gl-proj:viewport *display*)
(gl-proj:perspective *display*)
(gl-proj:orthographic *display*)
(enable-backface-culling)

;-------

(gl:Enable gl:BLEND)
(gl:BlendFunc gl:ONE gl:ONE_MINUS_SRC_ALPHA)

;-------

(define *continue* #t)

(require 'srfi-13)

(define *buffer* "")
(define (buffer:empty)
  (set! *buffer* ""))
(define (buffer:left-paren)
  (set! *buffer* (string-append *buffer* "(")))
(define (buffer:right-paren)
  (set! *buffer* (string-append *buffer* ")")))
(define (buffer:char char)
  (set! *buffer* (string-append *buffer* (string char))))
(define (buffer:backspace)
  (unless (string-null? *buffer*)
    (set! *buffer* (string-drop-right *buffer* 1))))
(define (buffer:form)
  (read (open-input-string *buffer*)))
(define (buffer:string)
  *buffer*)

;(define old-out-port (current-output-port))
(define *output-buffer* "")
;(define *output-buffer* (open-output-string))
;(current-output-port *output-buffer*)
;(current-output-port old-out-port)

(define (char-for-command? o)
  (and (char? o)
       (or (char-alphabetic? o)
           (char-numeric? o)
           (char-whitespace? o)
           (case o
             ((#\") #t)
             (else #f)       
             ))))

(define (event-for-command event)
  (if (key-pressed? event)
    (let ((key (gl-display:event-key event)))
      (cond ((eq? key #\()
             (buffer:left-paren)
             #t)
            ((eq? key #\))
             (buffer:right-paren)
             #t)
            ((eq? key #\return)
            ;(events:send 'commands (list 'command (gl-display:time) '(print "command")))
             (events:send 'commands (list 'command (gl-display:time) (buffer:form)))
             (buffer:empty)
             #t)
            ((eq? key #\backspace)
             (buffer:backspace))
            ((char-for-command? key)
             (buffer:char key)
             #t)
            (else #f)))
    #f))

(events:handle 'gui
    (lambda (event)
      (let ((e-for-c (event-for-command event)))
        (cond (e-for-c)
              ((escape-key-released? event)
               (events:send 'commands (list 'command (gl-display:time) '(quit))))))))

(define (quit) (set! *continue* #f))
(events:handle 'commands (lambda (event)
    (print "command: " event)
    (let ((command (third event)))
      (unless (null? command)
        (set! *output-buffer*
          (with-output-to-string
            (lambda _
              (condition-case (eval command)
                              (var () (print "an exception occured in the command"))))))))))

(define (render)
  (clear)
  (gl:Color3f 0 0 0)
  (load-identity)
  (preserving-matrices
    (gl:Translatef (* (gl-display:width *display*) -0.4) 0 0)
    (gl-font:print (string-append "> " (buffer:string))))
  (gl:Translatef (* (gl-display:width *display*) -0.4) -40 0)
  (gl-font:print (string-append "; " *output-buffer*))
  (gl-display:swap *display*))

(define (go)
  (let loop ()
    (when *continue*
      (process-events *display* (lambda (event) (events:send 'gui event)))
      (events:schedule)
      (render)
      (thread-sleep! 0.02)
      (loop)))
  (gl-display:destroy *display*))

(gl:Enable gl:TEXTURE_2D)
(go)