1 ;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
2 ;;; Copyright (C) 2020 Javier Sancho <jsf@jsancho.org>
4 ;;; This file is part of guile-irrlicht.
6 ;;; Guile-irrlicht is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation; either version 3 of the
9 ;;; License, or (at your option) any later version.
11 ;;; Guile-irrlicht is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with guile-irrlicht. If not, see
18 ;;; <http://www.gnu.org/licenses/>.
21 ;;; Irrlicht 05.User Interface example
22 ;;; http://irrlicht.sourceforge.net/docu/example005.html
25 (use-modules (irrlicht)
28 ;; ask user for driver
30 "Please select the driver you want for this example:
34 (d) Burning's Software Renderer
39 (define device-type (match (read-char)
48 (when (not device-type)
51 ;; set the skin transparency by changing the alpha values of all skin-colors
52 (define (set-skin-transparency alpha skin)
53 (let loop ((default-colors '(3d-dark-shadow 3d-shadow 3d-face 3d-high-light 3d-light
54 active-border active-caption app-workspace button-text
55 gray-text high-light high-light-text inactive-border
56 inactive-caption tooltip tooltip-background scrollbar
57 window window-symbol icon icon-high-light gray-window-symbol
58 editable gray-editable focused-editable)))
59 (cond ((not (null? default-colors))
60 (let* ((default-color (car default-colors))
61 (color (get-color skin default-color))
62 (new-color (cons alpha (cdr color))))
63 (set-color! skin default-color new-color))
64 (loop (cdr default-colors))))))
69 #:device-type device-type
70 #:window-size '(640 480)))
72 (set-window-caption! device "Irrlicht Engine - User Interface Demo")
73 (set-resizable! device #t)
75 (define driver (get-video-driver device))
76 (define gui-env (get-gui-environment device))
78 ;; load an external font and set it as the new default font in the skin
79 (let ((skin (get-skin gui-env))
80 (font (get-font gui-env "media/fonthaettenschweiler.bmp")))
82 (set-font! skin (get-built-in-font gui-env) #:which 'tooltip))
84 ;; define some values that we'll use to identify individual GUI controls
85 (define GUI-ID-QUIT-BUTTON 101)
86 (define GUI-ID-NEW-WINDOW-BUTTON 102)
87 (define GUI-ID-FILE-OPEN-BUTTON 103)
88 (define GUI-ID-TRANSPARENCY-SCROLLBAR 104)
90 ;; add three buttons, the first one closes the engine, the second creates a window
91 ;; and the third opens a file open dialog
92 (add-button! gui-env '(10 240 110 272)
93 #:id GUI-ID-QUIT-BUTTON
95 #:tooltiptext "Exits Program")
96 (add-button! gui-env '(10 280 110 312)
97 #:id GUI-ID-NEW-WINDOW-BUTTON
99 #:tooltiptext "Launches a new window")
100 (add-button! gui-env '(10 320 110 352)
101 #:id GUI-ID-FILE-OPEN-BUTTON
103 #:tooltiptext "Opens a file")
105 ;; we add a scrollbar and a listbox
106 (add-static-text! gui-env "Transparent Control:" '(150 20 350 40) #:border #t)
107 (let ((scrollbar (add-scrollbar! gui-env #t '(150 45 350 60) #:id GUI-ID-TRANSPARENCY-SCROLLBAR)))
108 (set-max! scrollbar 255)
109 (set-position! scrollbar 255)
110 (set-skin-transparency (get-position scrollbar) (get-skin gui-env))
111 (let ((alpha (car (get-color (get-skin gui-env) 'window))))
112 (set-position! scrollbar alpha)))
114 (add-static-text! gui-env "Logging ListBox:" '(50 110 250 130 #t))
115 (define listbox (add-listbox! gui-env '(50 140 250 210)))
116 (add-editbox! gui-env "Editable Text" '(350 80 550 100))
118 ;; create the event receiver
119 (define open-new-window #f)
121 (set! open-new-window
123 (add-item! listbox "Window created")
124 (set! counter (+ counter 30))
127 (let* ((window-size (list (+ counter 100)
131 (window (add-window! gui-env window-size #:text "Test window")))
132 (add-static-text! gui-env "Please close me" '(35 35 140 50)
137 (define (on-event event)
138 (if (equal? (get-event-type event) 'gui-event)
139 (let* ((caller (get-event-gui-caller event))
141 (event-type (get-event-gui-type event)))
143 (cond ((equal? event-type 'scrollbar-changed)
144 (if (= id GUI-ID-TRANSPARENCY-SCROLLBAR)
145 (let ((pos (get-position caller)))
146 (set-skin-transparency pos (get-skin gui-env))))
149 ((equal? event-type 'button-clicked)
150 (cond ((= id GUI-ID-QUIT-BUTTON)
152 (close-device device)
155 ((= id GUI-ID-NEW-WINDOW-BUTTON)
160 ((= id GUI-ID-FILE-OPEN-BUTTON)
162 (add-item! listbox "File open")
163 (add-file-open-dialog! gui-env
164 #:title "Please choose a file"
170 ((equal? event-type 'file-selected)
171 (add-item! listbox (get-file-name caller))
178 (set-event-receiver! device (make-event-receiver on-event))
180 ;; Irrlicht Engine logo in the top left corner
181 (add-image! gui-env (get-texture driver "media/irrlichtlogo2.png") '(10 10))
185 (when (is-window-active? device)
186 (begin-scene driver #:color '(0 200 200 200))