--- /dev/null
+;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
+;;; Copyright (C) 2020 Javier Sancho <jsf@jsancho.org>
+;;;
+;;; This file is part of guile-irrlicht.
+;;;
+;;; Guile-irrlicht is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-irrlicht is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with guile-irrlicht. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+;;; Irrlicht 05.User Interface example
+;;; http://irrlicht.sourceforge.net/docu/example005.html
+
+
+(use-modules (irrlicht)
+ (ice-9 match))
+
+;; ask user for driver
+(format #t
+ "Please select the driver you want for this example:
+ (a) OpenGL 1.5
+ (b) Direct3D 9.0c
+ (c) Direct3D 8.1
+ (d) Burning's Software Renderer
+ (e) Software Renderer
+ (f) NullDevice
+ (otherKey) exit~%~%")
+
+(define device-type (match (read-char)
+ (#\a 'opengl)
+ (#\b 'direct3d9)
+ (#\c 'direct3d8)
+ (#\d 'burnings)
+ (#\e 'software)
+ (#\f 'null)
+ (_ #f)))
+
+(when (not device-type)
+ (exit #f))
+
+;; set the skin transparency by changing the alpha values of all skin-colors
+(define (set-skin-transparency alpha skin)
+ (let loop ((default-colors '(3d-dark-shadow 3d-shadow 3d-face 3d-high-light 3d-light
+ active-border active-caption app-workspace button-text
+ gray-text high-light high-light-text inactive-border
+ inactive-caption tooltip tooltip-background scrollbar
+ window window-symbol icon icon-high-light gray-window-symbol
+ editable gray-editable focused-editable)))
+ (cond ((not (null? default-colors))
+ (let* ((default-color (car default-colors))
+ (color (get-color skin default-color))
+ (new-color (cons alpha (cdr color))))
+ (set-color! skin default-color new-color))
+ (loop (cdr default-colors))))))
+
+;; create device
+(define device
+ (create-device
+ #:device-type device-type
+ #:window-size '(640 480)))
+
+(set-window-caption! device "Irrlicht Engine - User Interface Demo")
+(set-resizable! device #t)
+
+(define driver (get-video-driver device))
+(define gui-env (get-gui-environment device))
+
+;; load an external font and set it as the new default font in the skin
+(let ((skin (get-skin gui-env))
+ (font (get-font gui-env "media/fonthaettenschweiler.bmp")))
+ (set-font! skin font)
+ (set-font! skin (get-built-in-font gui-env) #:which 'tooltip))
+
+;; define some values that we'll use to identify individual GUI controls
+(define GUI-ID-QUIT-BUTTON 101)
+(define GUI-ID-NEW-WINDOW-BUTTON 102)
+(define GUI-ID-FILE-OPEN-BUTTON 103)
+(define GUI-ID-TRANSPARENCY-SCROLLBAR 104)
+
+;; add three buttons, the first one closes the engine, the second creates a window
+;; and the third opens a file open dialog
+(add-button! gui-env '(10 240 110 272)
+ #:id GUI-ID-QUIT-BUTTON
+ #:text "Quit"
+ #:tooltiptext "Exits Program")
+(add-button! gui-env '(10 280 110 312)
+ #:id GUI-ID-NEW-WINDOW-BUTTON
+ #:text "New Window"
+ #:tooltiptext "Launches a new window")
+(add-button! gui-env '(10 320 110 352)
+ #:id GUI-ID-FILE-OPEN-BUTTON
+ #:text "File Open"
+ #:tooltiptext "Opens a file")
+
+;; we add a scrollbar and a listbox
+(add-static-text! gui-env "Transparent Control:" '(150 20 350 40) #:border #t)
+(let ((scrollbar (add-scrollbar! gui-env #t '(150 45 350 60) #:id GUI-ID-TRANSPARENCY-SCROLLBAR)))
+ (set-max! scrollbar 255)
+ (set-position! scrollbar 255)
+ (set-skin-transparency (get-position scrollbar) (get-skin gui-env))
+ (let ((alpha (car (get-color (get-skin gui-env) 'window))))
+ (set-position! scrollbar alpha)))
+
+(add-static-text! gui-env "Logging ListBox:" '(50 110 250 130 #t))
+(define listbox (add-listbox! gui-env '(50 140 250 210)))
+(add-editbox! gui-env "Editable Text" '(350 80 550 100))
+
+;; create the event receiver
+(define open-new-window #f)
+(let ((counter 0))
+ (set! open-new-window
+ (lambda ()
+ (add-item! listbox "Window created")
+ (set! counter (+ counter 30))
+ (if (> counter 200)
+ (set! counter 0))
+ (let* ((window-size (list (+ counter 100)
+ (+ counter 100)
+ (+ counter 300)
+ (+ counter 200)))
+ (window (add-window! gui-env window-size #:text "Test window")))
+ (add-static-text! gui-env "Please close me" '(35 35 140 50)
+ #:border #t
+ #:word-wrap #f
+ #:parent window)))))
+
+(define (on-event event)
+ (if (equal? (get-event-type event) 'gui-event)
+ (let* ((caller (get-event-gui-caller event))
+ (id (get-id caller))
+ (event-type (get-event-gui-type event)))
+
+ (cond ((equal? event-type 'scrollbar-changed)
+ (if (= id GUI-ID-TRANSPARENCY-SCROLLBAR)
+ (let ((pos (get-position caller)))
+ (set-skin-transparency pos (get-skin gui-env))))
+ #f)
+
+ ((equal? event-type 'button-clicked)
+ (cond ((= id GUI-ID-QUIT-BUTTON)
+ ;; quit
+ (close-device device)
+ #t)
+
+ ((= id GUI-ID-NEW-WINDOW-BUTTON)
+ ;; new-window
+ (open-new-window)
+ #t)
+
+ ((= id GUI-ID-FILE-OPEN-BUTTON)
+ ;; open file
+ (add-item! listbox "File open")
+ (add-file-open-dialog! gui-env
+ #:title "Please choose a file"
+ #:restore-cwd #t)
+ #t)
+
+ (else #f)))
+
+ ((equal? event-type 'file-selected)
+ (add-item! listbox (get-file-name caller))
+ #f)
+
+ (else #f)))
+
+ #f))
+
+(set-event-receiver! device (make-event-receiver on-event))
+
+;; Irrlicht Engine logo in the top left corner
+(add-image! gui-env (get-texture driver "media/irrlichtlogo2.png") '(10 10))
+
+;; game loop
+(while (run device)
+ (when (is-window-active? device)
+ (begin-scene driver #:color '(0 200 200 200))
+ (draw-all gui-env)
+ (end-scene driver)))
+
+;; delete device
+(drop! device)
+(exit #t)
projects / guile-irrlicht.git / commitdiff
