examples/05-user-interface.scm

   1 ;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
   2 ;;; Copyright (C) 2020 Javier Sancho <jsf@jsancho.org>
   3 ;;;
   4 ;;; This file is part of guile-irrlicht.
   5 ;;;
   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.
  10 ;;;
  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.
  15 ;;;
  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/>.
  19
  20
  21 ;;; Irrlicht 05.User Interface example
  22 ;;; http://irrlicht.sourceforge.net/docu/example005.html
  23
  24
  25 (use-modules (irrlicht)
  26              (ice-9 match))
  27
  28 ;; ask user for driver
  29 (format #t
  30         "Please select the driver you want for this example:
  31  (a) OpenGL 1.5
  32  (b) Direct3D 9.0c
  33  (c) Direct3D 8.1
  34  (d) Burning's Software Renderer
  35  (e) Software Renderer
  36  (f) NullDevice
  37  (otherKey) exit~%~%")
  38
  39 (define device-type (match (read-char)
  40                            (#\a 'opengl)
  41                            (#\b 'direct3d9)
  42                            (#\c 'direct3d8)
  43                            (#\d 'burnings)
  44                            (#\e 'software)
  45                            (#\f 'null)
  46                            (_ #f)))
  47
  48 (when (not device-type)
  49   (exit #f))
  50
  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))))))
  65
  66 ;; create device
  67 (define device
  68   (create-device
  69    #:device-type device-type
  70    #:window-size '(640 480)))
  71
  72 (set-window-caption! device "Irrlicht Engine - User Interface Demo")
  73 (set-resizable! device #t)
  74
  75 (define driver (get-video-driver device))
  76 (define gui-env (get-gui-environment device))
  77
  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")))
  81   (set-font! skin font)
  82   (set-font! skin (get-built-in-font gui-env) #:which 'tooltip))
  83
  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)
  89
  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
  94              #:text "Quit"
  95              #:tooltiptext "Exits Program")
  96 (add-button! gui-env '(10 280 110 312)
  97              #:id GUI-ID-NEW-WINDOW-BUTTON
  98              #:text "New Window"
  99              #:tooltiptext "Launches a new window")
 100 (add-button! gui-env '(10 320 110 352)
 101              #:id GUI-ID-FILE-OPEN-BUTTON
 102              #:text "File Open"
 103              #:tooltiptext "Opens a file")
 104
 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)))
 113
 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))
 117
 118 ;; create the event receiver
 119 (define open-new-window #f)
 120 (let ((counter 0))
 121   (set! open-new-window
 122         (lambda ()
 123           (add-item! listbox "Window created")
 124           (set! counter (+ counter 30))
 125           (if (> counter 200)
 126               (set! counter 0))
 127           (let* ((window-size (list (+ counter 100)
 128                                     (+ counter 100)
 129                                     (+ counter 300)
 130                                     (+ counter 200)))
 131                  (window (add-window! gui-env window-size #:text "Test window")))
 132             (add-static-text! gui-env "Please close me" '(35 35 140 50)
 133                               #:border #t
 134                               #:word-wrap #f
 135                               #:parent window)))))
 136
 137 (define (on-scrollbar-event id caller)
 138   (if (= id GUI-ID-TRANSPARENCY-SCROLLBAR)
 139       (let ((pos (get-position caller)))
 140         (set-skin-transparency pos (get-skin gui-env))))
 141   #f)
 142
 143 (define (on-button-event id)
 144   (cond ((= id GUI-ID-QUIT-BUTTON)
 145          ;; quit
 146          (close-device device)
 147          #t)
 148
 149         ((= id GUI-ID-NEW-WINDOW-BUTTON)
 150          ;; new-window
 151          (open-new-window)
 152          #t)
 153
 154         ((= id GUI-ID-FILE-OPEN-BUTTON)
 155          ;; open file
 156          (add-item! listbox "File open")
 157          (add-file-open-dialog! gui-env
 158                                 #:title "Please choose a file"
 159                                 #:restore-cwd #t)
 160          #t)
 161
 162         (else #f)))
 163
 164 (define (on-file-selected-event caller)
 165   (add-item! listbox (get-file-name caller))
 166   #f)
 167
 168 (define (on-gui-event event)
 169   (let* ((caller (get-event-gui-caller event))
 170          (id (get-id caller))
 171          (event-type (get-event-gui-type event)))
 172     (cond ((equal? event-type 'scrollbar-changed)
 173            (on-scrollbar-event id caller))
 174           ((equal? event-type 'button-clicked)
 175            (on-button-event id))
 176           ((equal? event-type 'file-selected)
 177            (on-file-selected-event caller))
 178           (else #f))))
 179
 180 (define (on-event event)
 181   (if (equal? (get-event-type event) 'gui-event)
 182       (on-gui-event event)
 183       #f))
 184
 185 (set-event-receiver! device (make-event-receiver on-event))
 186
 187 ;; Irrlicht Engine logo in the top left corner
 188 (add-image! gui-env (get-texture driver "media/irrlichtlogo2.png") '(10 10))
 189
 190 ;; game loop
 191 (while (run device)
 192   (when (is-window-active? device)
 193     (begin-scene driver #:color '(0 200 200 200))
 194     (draw-all gui-env)
 195     (end-scene driver)))
 196
 197 ;; delete device
 198 (drop! device)
 199 (exit #t)