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

Last change on this file since 3309 was 3309, checked in by thu, 14 years ago

initial commit

  • Property svn:executable set to *
File size: 3.2 KB
Line 
1#! /bin/sh
2#|
3exec csi -s $0 "$@"
4|#
5
6(require-extension gl-display-glx)
7(require-extension gl-font)
8(require 'gl-display-events-util)
9(require 'gl-display-event-queue)
10(require 'gl-util)
11(require 'gl-proj)
12
13
14(define *display* (gl-display:create 'width 400 'height 400))
15(gl-font:create-from-path "/usr/share/fonts/truetype/ttf-dejavu/DejaVuSansMono.ttf")
16(gl-util:initialize)
17(gl-proj:viewport *display*)
18(gl-proj:perspective *display*)
19(gl-proj:orthographic *display*)
20(enable-backface-culling)
21
22;-------
23
24(gl:Enable gl:BLEND)
25(gl:BlendFunc gl:ONE gl:ONE_MINUS_SRC_ALPHA)
26
27;-------
28
29(define *continue* #t)
30
31(require 'srfi-13)
32
33(define *buffer* "")
34(define (buffer:empty)
35  (set! *buffer* ""))
36(define (buffer:left-paren)
37  (set! *buffer* (string-append *buffer* "(")))
38(define (buffer:right-paren)
39  (set! *buffer* (string-append *buffer* ")")))
40(define (buffer:char char)
41  (set! *buffer* (string-append *buffer* (string char))))
42(define (buffer:backspace)
43  (unless (string-null? *buffer*)
44    (set! *buffer* (string-drop-right *buffer* 1))))
45(define (buffer:form)
46  (read (open-input-string *buffer*)))
47(define (buffer:string)
48  *buffer*)
49
50;(define old-out-port (current-output-port))
51(define *output-buffer* "")
52;(define *output-buffer* (open-output-string))
53;(current-output-port *output-buffer*)
54;(current-output-port old-out-port)
55
56(define (char-for-command? o)
57  (and (char? o)
58       (or (char-alphabetic? o)
59           (char-numeric? o)
60           (char-whitespace? o)
61           (case o
62             ((#\") #t)
63             (else #f)       
64             ))))
65
66(define (event-for-command event)
67  (if (key-pressed? event)
68    (let ((key (gl-display:event-key event)))
69      (cond ((eq? key #\()
70             (buffer:left-paren)
71             #t)
72            ((eq? key #\))
73             (buffer:right-paren)
74             #t)
75            ((eq? key #\return)
76            ;(events:send 'commands (list 'command (gl-display:time) '(print "command")))
77             (events:send 'commands (list 'command (gl-display:time) (buffer:form)))
78             (buffer:empty)
79             #t)
80            ((eq? key #\backspace)
81             (buffer:backspace))
82            ((char-for-command? key)
83             (buffer:char key)
84             #t)
85            (else #f)))
86    #f))
87
88(events:handle 'gui
89    (lambda (event)
90      (let ((e-for-c (event-for-command event)))
91        (cond (e-for-c)
92              ((escape-key-released? event)
93               (events:send 'commands (list 'command (gl-display:time) '(quit))))))))
94
95(define (quit) (set! *continue* #f))
96(events:handle 'commands (lambda (event)
97    (print "command: " event)
98    (let ((command (third event)))
99      (unless (null? command)
100        (set! *output-buffer*
101          (with-output-to-string
102            (lambda _
103              (condition-case (eval command)
104                              (var () (print "an exception occured in the command"))))))))))
105
106(define (render)
107  (clear)
108  (gl:Color3f 0 0 0)
109  (load-identity)
110  (preserving-matrices
111    (gl:Translatef (* (gl-display:width *display*) -0.4) 0 0)
112    (gl-font:print (string-append "> " (buffer:string))))
113  (gl:Translatef (* (gl-display:width *display*) -0.4) -40 0)
114  (gl-font:print (string-append "; " *output-buffer*))
115  (gl-display:swap *display*))
116
117(define (go)
118  (let loop ()
119    (when *continue*
120      (process-events *display* (lambda (event) (events:send 'gui event)))
121      (events:schedule)
122      (render)
123      (thread-sleep! 0.02)
124      (loop)))
125  (gl-display:destroy *display*))
126
127(gl:Enable gl:TEXTURE_2D)
128(go)
Note: See TracBrowser for help on using the repository browser.