Print Page - Gauche Scheme

Information => Open Forum => Topic started by: JRS on January 17, 2015, 12:17:40 AM

Title: Gauche Scheme
Post by: JRS on January 17, 2015, 12:17:40 AM

I discovered Gauche Scheme interpreter today and compiled it under Ubuntu 64 bit. I also compiled the OpenGL extension module. Here is a Mandelbrot example. (it displayed almost instantly) What is really unique (to me) is if I resize the window, the image is redrawn instantly.

Gauche Project Site (http://practical-scheme.net/gauche/index.html)

Note: This was the Scheme used on the Coding Ground (CompileOnLine.com) site.

Code: Scheme

;;
;; Calculate and show Mandelbrot set.
;;
 
(use gauche.uvector)
(use gl)
(use gl.glut)
(use math.const)
 
(define *size*  256)
(define *image* (make-u8vector (* *size* *size* 3) 0))
(define *tex* #f)
 
(define *speed-phi* 0)
(define *xrot* 0)
(define *yrot* 0)
 
(define (fill-image)
  (dotimes (y *size*)
    (dotimes (x *size*)
      (let ((i (* (+ (* y *size*) x) 3))
            (z (make-rectangular (- (* 3 (/ x *size*)) 2)
                                 (- (* 3 (/ y *size*)) 1.5))))
        (letrec ((rank (lambda (zn n)
                         (cond ((>= n 16) 0)
                               ((>= (magnitude zn) 2) n)
                               (else (rank (+ (* zn zn) z) (+ n 1)))))))
          (let ((r (rank z 0)))
            (u8vector-set! *image* i       (ash (logand r #xc) 4))
            (u8vector-set! *image* (+ i 1) (ash (logand r #x2) 6))
            (u8vector-set! *image* (+ i 2) (ash (logand r #x1) 7))
            ))))))
 
(define (init)
  (fill-image)
  (gl-clear-color 0.0 0.0 0.0 0.0)
  (gl-shade-model GL_FLAT)
  (set! *tex* (u32vector-ref (gl-gen-textures 1) 0))
  (gl-bind-texture GL_TEXTURE_2D *tex*)
  (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT)
  (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT)
  (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST)
  (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST)
  (gl-tex-image-2d GL_TEXTURE_2D 0 GL_RGB *size* *size* 0
                   GL_RGB GL_UNSIGNED_BYTE *image*)
  )
 
(define (disp)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-enable GL_TEXTURE_2D)
  (gl-tex-env GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_REPLACE)
  (gl-bind-texture GL_TEXTURE_2D *tex*)
  (gl-push-matrix)
  (gl-load-identity)
  (gl-translate 0.5 0.5 0.0)
  (gl-rotate *xrot* 1.0 0.0 0.0)
  (gl-rotate *yrot* 0.0 1.0 0.0)
  (gl-translate -0.5 -0.5 0.0)
  (gl-begin GL_QUADS)
  (gl-tex-coord '#f32(0.0 0.0)) (gl-vertex '#f32(0.0 0.0))
  (gl-tex-coord '#f32(0.0 1.0)) (gl-vertex '#f32(0.0 1.0))
  (gl-tex-coord '#f32(1.0 1.0)) (gl-vertex '#f32(1.0 1.0))
  (gl-tex-coord '#f32(1.0 0.0)) (gl-vertex '#f32(1.0 0.0))
  (gl-end)
  (gl-pop-matrix)
  (glut-swap-buffers)
  (gl-disable GL_TEXTURE_2D)
  (animate)
  )
 
(define (reshape w h)
  (gl-viewport 0 0 w h)
  (gl-matrix-mode GL_PROJECTION)
  (gl-load-identity)
  (glu-ortho-2d 0 1 0 1)
  (gl-matrix-mode GL_MODELVIEW)
  (gl-load-identity)
  )
 
(define (animate)
  (let1 speed (abs (sin (* *speed-phi* pi/180)))
    (set! *xrot* (fmod (+ *xrot* (/ speed 172.0)) 360.0))
    (set! *yrot* (fmod (+ *yrot* (/ speed 334.0)) 360.0))
    (set! *speed-phi* (fmod (+ *speed-phi* 0.003) 360.0)))
  (glut-post-redisplay)
  )
 
(define (main args)
  (glut-init args)
  (glut-init-display-mode (logior GLUT_DOUBLE GLUT_RGB))
  (glut-init-window-size 256 256)
  (glut-create-window "mandelbrot")
  (init)
;  (glut-idle-func animate)
  (glut-reshape-func reshape)
  (glut-display-func disp)
  (glut-main-loop)
  0
  )
 

Title: Re: Gauche Scheme
Post by: RobbeK on January 17, 2015, 03:09:31 AM

Hi John,

rather fast , made in Japan it seems , full numeric tower and takes some interesting ideas from Common Lisp (dotimes , incf , decf etc ...)
also installs SLIB !!!

testing : splitting 10,000,000 numbers (0... ..999) in even and odd

Setting up gauche (0.9.3.3-8ubuntu1) ...
Setting up slib (3b1-3.1) ...
Processing triggers for libc-bin (2.19-0ubuntu6.4) ...
gerd@gerd-HP-Pavilion-dv4000-EK987EA-UUG:~$ gosh
gosh> (define (tst)
(let ((a 0) (b 0))
(dotimes (i 10000000 (list a b))
(if (even? i) (inc! a) (inc! b)))))
tst
gosh> (tst)
(5000000 5000000)
gosh> (time (tst))
;(time (tst))
; real 1.942
; user 1.810
; sys 0.000
(5000000 5000000)

faster than NewLISP (which is fast)

newLISP v.10.6.0 32-bit on Linux IPv4/6 libffi, options: newlisp -h

>
(lambda ()
(let ((a 0) (b 0))
(dotimes (i 10000000)
(if (even? i)
(++ a)
(++ b)))
(list a b)))
> (time (tst))
2775.392

> compare with Austin Kyoto CL (interpreted and compiled)

GCL (GNU Common Lisp) 2.6.10 CLtL1 Apr 2 2014 14:19:37
Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl)
Binary License: GPL due to GPL'ed components: (XGCL READLINE UNEXEC)
Modifications of this banner must retain notice of a compatible license
Dedicated to the memory of W. Schelter

Use (help) to get some basic information on how to use GCL.
Temporary directory for compiler files set to /tmp/

>(defun tst ()
(let ((a 0) (b 0))
(dotimes (i 10000000 (list a b))
(if (evenp i) (incf a) (incf b)))))

TST

>(time (tst))

real time

: 3.779 secs
run-gbc time : 3.099 secs
child run time : 0.000 secs
gbc time : 0.109 secs
(5000000 5000000)

>(compile 'tst)

Compiling /tmp/gazonk_4102_0.lsp.
End of Pass 1.
End of Pass 2.
OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3
Finished compiling /tmp/gazonk_4102_0.lsp.
Loading /tmp/gazonk_4102_0.o
start address -T 0x8a36d0 Finished loading /tmp/gazonk_4102_0.o
#<compiled-function TST>
NIL
NIL

>(time (tst))

real time : 0.059 secs
run-gbc time : 0.039 secs
child run time : 0.000 secs
gbc time : 0.000 secs
(5000000 5000000)

>
best, Rob

Title: Re: Gauche Scheme
Post by: RobbeK on January 18, 2015, 05:26:07 AM

Hi John,

http://www.koguro.net/prog/dyncomp/index.html

Starting to like Gauche very much 8)

best, Rob

Title: Re: Gauche Scheme
Post by: JRS on January 18, 2015, 08:54:37 AM

Rob,

That is great news! I'm glad you found a Scheme language you like. Are your running Gauche under Linux or Windows?

John

Title: Re: Gauche Scheme
Post by: RobbeK on January 18, 2015, 10:10:47 AM

Hi John,

Under Linux for the moment , but the editor under Wine (LispIDE -- has Scheme syntax highlighting and parens matching ), but on another computer I have it both for Win and Linux (I always had Ubuntu on it - mainly for the web, mobile network (tethering etc..) and repair windows files hit by malware , the Libre Office , export to PDF , reading PS and deja-vu files, edit PDF's etc .. ) I do my very best not to use pirated software (which is imo the success of windows -- I mean the high amount of pirate copies makes it popular - everyone has a PhotoShop these days , 99 out of 100 an illegal copy :-[ (and furthermore used by people who simply do not need such complicated programs --it's amazing what I get in my mailbox sometimes -- invitations made on a spread sheet etc ... it's very sad ... if they had to buy legal copies , Linux would be much more popular (though i'm somewhat worried about the increasing fragmentation at this moment)

best, Rob

Title: Re: Gauche Scheme
Post by: JRS on January 18, 2015, 10:25:26 AM

Quote

it's very sad ... if they had to buy legal copies , Linux would be much more popular (though i'm somewhat worried about the increasing fragmentation at this moment)

Actually bootleg software helps more than it hurts. Think about it. People buy software they plan to use. Most users have been burnt and spent money on crap the vendor did a great marketing effort on. Most bootleg software installs go in one of two directions. The pirate likes the software and ends up buying it for the support and upgrade aspect. The other direction is it's used once or twice and then deleted for the next item on the plate.

Linux and open source eliminates those steps and mess that goes along with it. The idea behind open source is to use existing code and make whatever your doing better.

Title: Re: Gauche Scheme
Post by: JRS on January 18, 2015, 08:31:40 PM

Quote from: Rob

but the editor under Wine (LispIDE -- has Scheme syntax highlighting and parens matching )

I use UltraEdit under Linux and Windows. The license covers up to three instances of whatever OS it supports. This example is using the Scheme syntax highlighting definition file. They are easy to expand on and the options are extensive. The other cool thing about UE is it's scripting engine is JavaScript.

.

Title: Re: Gauche Scheme
Post by: JRS on January 18, 2015, 10:38:22 PM

Rob,

I built the Gauche GtkGLExt and GD (with PangoFT2 support) which should finally wean you off the JAPI tit. ;D

301 in 5.010643 seconds = 60.07213046309625 FPS

Code: Scheme

;;
;; 3-D gear wheels.  This program is in the public domain.
;;
;; Brian Paul
;;
;; Conversion to GLUT by Mark J. Kilgard
;; Conversion to GtkGLExt by Naofumi Yasufuku
;; Port to Scheme by Shiro Kawai
 
(use math.const)
(use gtk)
(use gtk.gtkgl)
(use gl)
 
;; Draw a gear wheel.  You'll probably want to call this function when
;; building a display list since we do a lot of trig here.
;;
;; Input:  inner_radius - radius of hole at center
;; outer_radius - radius at center of teeth
;; width - width of gear
;; teeth - number of teeth
;; tooth_depth - depth of tooth
 
(define (gear inner-radius outer-radius width teeth tooth-depth)
  (let ((r0 inner-radius)
        (r1 (- outer-radius (/ tooth-depth 2.0)))
        (r2 (+ outer-radius (/ tooth-depth 2.0)))
        (da (* 2.0 (/ pi teeth 4.0))))
    (gl-shade-model GL_FLAT)
    (gl-normal 0.0 0.0 1.0)
 
    ;; draw front face
    (gl-begin GL_QUAD_STRIP)
    (dotimes (i (+ teeth 1))
      (let1 angle (* i 2.0 (/ pi teeth))
        (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
        (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
        (when (< i teeth)
          (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
          (gl-vertex (* r1 (cos (+ angle (* 3 da))))
                     (* r1 (sin (+ angle (* 3 da))))
                     (* width 0.5)))))
    (gl-end)
 
    ;; draw front sides of teeth
    (gl-begin GL_QUADS)
    (dotimes (i teeth)
      (let1 angle (* i 2.0 (/ pi teeth))
        (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
        (gl-vertex (* r2 (cos (+ angle da)))
                   (* r2 (sin (+ angle da)))
                   (* width 0.5))
        (gl-vertex (* r2 (cos (+ angle (* 2 da))))
                   (* r2 (sin (+ angle (* 2 da))))
                   (* width 0.5))
        (gl-vertex (* r1 (cos (+ angle (* 3 da))))
                   (* r1 (sin (+ angle (* 3 da))))
                   (* width 0.5))))
    (gl-end)
 
    (gl-normal 0.0 0.0 -1.0)
 
    ;; draw back face
    (gl-begin GL_QUAD_STRIP)
    (dotimes (i (+ teeth 1))
      (let1 angle (* i 2.0 (/ pi teeth))
        (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
        (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
        (when (< i teeth)
          (gl-vertex (* r1 (cos (+ angle (* 3 da))))
                     (* r1 (sin (+ angle (* 3 da))))
                     (* width -0.5))
          (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
    (gl-end)
 
    ;; draw back sides of teeth
    (gl-begin GL_QUADS)
    (dotimes (i teeth)
      (let1 angle (* i 2.0 (/ pi teeth))
        (gl-vertex (* r1 (cos (+ angle (* 3 da))))
                   (* r1 (sin (+ angle (* 3 da))))
                   (* width -0.5))
        (gl-vertex (* r2 (cos (+ angle (* 2 da))))
                   (* r2 (sin (+ angle (* 2 da))))
                   (* width -0.5))
        (gl-vertex (* r2 (cos (+ angle da)))
                   (* r2 (sin (+ angle da)))
                   (* width -0.5))
        (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))))
    (gl-end)
 
    ;; draw outward faces of teeth
    (gl-begin GL_QUAD_STRIP)
    (dotimes (i teeth)
      (let* ((angle (* i 2.0 (/ pi teeth)))
             (u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
             (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
             (len (sqrt (+ (* u u) (* v v))))
             (uu (/ u len))
             (vv (/ v len)))
        (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
        (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
        (gl-normal v (- u) 0.0)
        (gl-vertex (* r2 (cos (+ angle da)))
                   (* r2 (sin (+ angle da)))
                   (* width 0.5))
        (gl-vertex (* r2 (cos (+ angle da)))
                   (* r2 (sin (+ angle da)))
                   (* width -0.5))
        (gl-normal (cos angle) (sin angle) 0.0)
        (gl-vertex (* r2 (cos (+ angle da da)))
                   (* r2 (sin (+ angle da da)))
                   (* width 0.5))
        (gl-vertex (* r2 (cos (+ angle da da)))
                   (* r2 (sin (+ angle da da)))
                   (* width -0.5))
        (gl-normal (- (* r1 (sin (+ angle da da da)))
                      (* r2 (sin (+ angle da da))))
                   (- (- (* r1 (cos (+ angle da da da)))
                      (* r2 (cos (+ angle da da)))))
                   0.0)
        (gl-vertex (* r1 (cos (+ angle da da da)))
                   (* r1 (sin (+ angle da da da)))
                   (* width 0.5))
        (gl-vertex (* r1 (cos (+ angle da da da)))
                   (* r1 (sin (+ angle da da da)))
                   (* width -0.5))
        (gl-normal (cos angle) (sin angle) 0.0)))
    (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
    (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5))
    (gl-end)
 
    (gl-shade-model GL_SMOOTH)
    ;; draw inside radius cylinder
    (gl-begin GL_QUAD_STRIP)
    (dotimes (i (+ teeth 1))
      (let1 angle (* i 2.0 (/ pi teeth))
        (gl-normal (- (cos angle)) (- (sin angle)) 0.0)
        (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
        (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))
    (gl-end)
    ))
 
(define *view-rotx* 20.0)
(define *view-roty* 30.0)
(define *view-rotz* 0.0)
(define *gear1* 0)
(define *gear2* 0)
(define *gear3* 0)
(define *angle* 0.0)
(define *timer* #f)
(define *frames* 0)
 
(define (draw widget . _)
  (let ((glcontext (gtk-widget-get-gl-context widget))
        (gldrawable (gtk-widget-get-gl-drawable widget)))
    ;;*** OpenGL BEGIN ***
    (when (gdk-gl-drawable-gl-begin gldrawable glcontext)
      (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
      (begin
        (gl-push-matrix)
        (gl-rotate *view-rotx* 1.0 0.0 0.0)
        (gl-rotate *view-roty* 0.0 1.0 0.0)
        (gl-rotate *view-rotz* 0.0 0.0 1.0)
        (begin
          (gl-push-matrix)
          (gl-translate -3.0 -2.0 0.0)
          (gl-rotate *angle* 0.0 0.0 1.0)
          (gl-call-list *gear1*)
          (gl-pop-matrix))
        (begin
          (gl-push-matrix)
          (gl-translate 3.1 -2.0 0.0)
          (gl-rotate (- (* -2.0 *angle*) 9.0) 0.0 0.0 1.0)
          (gl-call-list *gear2*)
          (gl-pop-matrix))
        (begin
          (gl-push-matrix)
          (gl-translate -3.1 4.2 0.0)
          (gl-rotate (- (* -2.0 *angle*) 25.0) 0.0 0.0 1.0)
          (gl-call-list *gear3*)
          (gl-pop-matrix))
        (gl-pop-matrix))
      (if (gdk-gl-drawable-is-double-buffered gldrawable)
          (gdk-gl-drawable-swap-buffers gldrawable)
          (gl-flush))
      (gdk-gl-drawable-gl-end gldrawable))
    
    (inc! *frames*)
    (let1 seconds (g-timer-elapsed *timer*)
      (when (>= seconds 5.0)
        (print #`",*frames* in ,seconds seconds = ,(/ *frames* seconds) FPS")
        (g-timer-reset *timer*)
        (set! *frames* 0)))
    #t))
 
;; new window size or exposure
(define (reshape widget . _)
  (let* ((glcontext (gtk-widget-get-gl-context widget))
         (gldrawable (gtk-widget-get-gl-drawable widget))
         (wsize (ref widget 'allocation))
         (h (/ (ref wsize 'height) (ref wsize 'width))))
    ;;*** OpenGL BEGIN ***
    (when (gdk-gl-drawable-gl-begin gldrawable glcontext)
      (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height))
      (gl-matrix-mode GL_PROJECTION)
      (gl-load-identity)
      (gl-frustum -1.0 1.0 (- h) h 5.0 60.0)
      (gl-matrix-mode GL_MODELVIEW)
      (gl-load-identity)
      (gl-translate 0.0 0.0 -40.0)
      (gdk-gl-drawable-gl-end gldrawable))
    ;;*** OpenGL END ***
    #t))
 
(define (init widget)
  (let ((glcontext (gtk-widget-get-gl-context widget))
        (gldrawable (gtk-widget-get-gl-drawable widget)))
    ;;*** OpenGL BEGIN ***
    (when (gdk-gl-drawable-gl-begin gldrawable glcontext)
      (gl-light GL_LIGHT0 GL_POSITION '#f32(5.0 5.0 10.0 0.0))
      (gl-enable GL_CULL_FACE)
      (gl-enable GL_LIGHTING)
      (gl-enable GL_LIGHT0)
      (gl-enable GL_DEPTH_TEST)
 
      ;; make the gears
      (set! *gear1* (gl-gen-lists 1))
      (gl-new-list *gear1* GL_COMPILE)
      (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.8 0.1 0.0 1.0))
      (gear 1.0 4.0 1.0 20 0.7)
      (gl-end-list)
 
      (set! *gear2* (gl-gen-lists 1))
      (gl-new-list *gear2* GL_COMPILE)
      (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.0 0.8 0.2 1.0))
      (gear 0.5 2.0 2.0 10 0.7)
      (gl-end-list)
 
      (set! *gear3* (gl-gen-lists 1))
      (gl-new-list *gear3* GL_COMPILE)
      (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.2 0.2 1.0 1.0))
      (gear 1.3 2.0 0.5 10 0.7)
      (gl-end-list)
      
      (gl-enable GL_NORMALIZE)
 
      (print)
      (print #`"GL_RENDERER   = ,(gl-get-string GL_RENDERER)")
      (print #`"GL_VERSION    = ,(gl-get-string GL_VERSION)")
      (print #`"GL_VENDOR     = ,(gl-get-string GL_VENDOR)")
      (print #`"GL_EXTENSIONS = ,(gl-get-string GL_EXTENSIONS)")
      (print)
 
      (gdk-gl-drawable-gl-end gldrawable))
    ;;*** OpenGL END ***
 
    ;; create timer
    (unless *timer* (set! *timer* (g-timer-new)))
    (g-timer-start *timer*)
    ))
 
(define (idle widget)
  (inc! *angle* 0.5)
  (if (> *angle* 360) (set! *angle* (fmod *angle* 360)))
  (gtk-widget-queue-draw widget)
  #t)
 
(define *idle-id* 0)
 
(define (map widget . _)
  (when (zero? *idle-id*)
    (set! *idle-id* (gtk-idle-add-priority GDK_PRIORITY_REDRAW
                                           (lambda _ (idle widget)))))
  #t)
 
(define (unmap widget . _)
  (unless (zero? *idle-id*)
    (gtk-idle-remove *idle-id*)
    (set! *idle-id* 0))
  #t)
 
(define (visible widget event)
  (if (= (ref event 'state) GDK_VISIBILITY_FULLY_OBSCURED)
      (unless (zero? *idle-id*)
              (gtk-idle-remove *idle-id*)
              (set! *idle-id* 0))
      (when (zero? *idle-id*)
        (set! *idle-id* (gtk-idle-add-priority GDK_PRIORITY_REDRAW
                                               (lambda _ (idle widget))))))
  #t)
 
;; change view angle, exit upon ESC 
(define (key widget event)
  (let ((kv (ref event 'keyval))
        (q  (lambda () (gtk-widget-queue-draw widget))))
    (cond
     ((= kv GDK_KEY_z)      (set! *view-rotz* (fmod (+ *view-rotz* 5.0) 360)) (q))
     ((= kv GDK_KEY_Z)      (set! *view-rotz* (fmod (- *view-rotz* 5.0) 360)) (q))
     ((= kv GDK_KEY_Up)     (set! *view-rotx* (fmod (+ *view-rotx* 5.0) 360)) (q))
     ((= kv GDK_KEY_Down)   (set! *view-rotx* (fmod (- *view-rotx* 5.0) 360)) (q))
     ((= kv GDK_KEY_Left)   (set! *view-roty* (fmod (+ *view-roty* 5.0) 360)) (q))
     ((= kv GDK_KEY_Right)  (set! *view-roty* (fmod (- *view-roty* 5.0) 360)) (q))
     ((= kv GDK_KEY_Escape) (gtk-main-quit))))
  #t)
 
(define (main args)
  (gtk-init args)
  (unless (gdk-gl-query-extension)
    (error "*** OpenGL is not supported."))
 
  ;;
  ;; Configure OpenGL-capable visual.
  ;;
  (let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB
                                                        GDK_GL_MODE_DEPTH
                                                        GDK_GL_MODE_DOUBLE))
                     (begin
                       (warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n")
                       (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB
                                                          GDK_GL_MODE_DEPTH)))
                     (error "*** No appropriate OpenGL-capable visual found.")
                     )
    ;;
    ;; Top-level window.
    ;;
    (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL)
      (gtk-window-set-title window "gears")
      (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit)))
      (g-signal-connect window "key_press_event" key)
      (g-signal-connect window "unmap_event" unmap)
      (let1 vbox (gtk-vbox-new #f 0)
        (gtk-container-add window vbox)
        (gtk-widget-show vbox)
        ;;
        ;; Drawing area for drawing OpenGL scene.
        ;;
        (let1 drawing-area (gtk-drawing-area-new)
          (gtk-widget-set-size-request drawing-area 300 300)
          ;; Set OpenGL-capability to the widget.
          (gtk-widget-set-gl-capability drawing-area glconfig #f #t
                                        GDK_GL_RGBA_TYPE)
          (gtk-box-pack-start vbox drawing-area #t #t 0)
          (gtk-widget-set-events drawing-area
                                 (logior GDK_EXPOSURE_MASK
                                         GDK_BUTTON_PRESS_MASK
                                         GDK_VISIBILITY_NOTIFY_MASK))
          (g-signal-connect drawing-area "realize" init)
          (g-signal-connect drawing-area "configure_event" reshape)
          (g-signal-connect drawing-area "expose_event" draw)
          (g-signal-connect drawing-area "map_event" map)
          (g-signal-connect drawing-area "unmap_event" unmap)
          (g-signal-connect drawing-area "visibility_notify_event" visible)
          (gtk-widget-show drawing-area))
        ;;
        ;; Simple quit button.
        ;;
        (let1 button (gtk-button-new-with-label "Quit")
          (gtk-box-pack-start vbox button #f #f 0)
          (g-signal-connect button "clicked" (lambda _ (gtk-main-quit)))
          (gtk-widget-show button))
        );vbox
      (gtk-widget-show window)
      )
    (gtk-main)
    0))
 

Title: Re: Gauche Scheme
Post by: JRS on January 18, 2015, 10:46:23 PM

Here is the Gtk GL GD example. As you mouse over the window client area, the color of the buttons change.

Code: Scheme

;;
;; like "simple", but using higher-level <gtk-graph-area> widget.
;; $Id: simple2.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $
;;
 
(use gtk)
(use gtk.gtkgl)
(use gtk.glgd)
 
(define *attr-geometry* 0)
(define *attr-skeleton* 1)
(define *attr-current* GLGD_ATTR_FORCEVISIBLE)
 
(define (main args)
  (gtk-init args)
  (unless (gdk-gl-query-extension)
    (error "*** OpenGL is not supported."))
 
  (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL)
    (gtk-window-set-title window "objview")
    (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit)))
    (let1 vbox (gtk-vbox-new #f 0)
      (gtk-container-add window vbox)
      (gtk-widget-show vbox)
      ;;
      ;; Drawing area for drawing OpenGL scene.
      ;;
      (let1 graph-area (make <gtk-graph-area>)
        (gtk-widget-set-size-request graph-area 640 480)
        (gtk-box-pack-start vbox graph-area #t #t 0)
        (graph-build-simple (ref graph-area 'graph))
        (gtk-widget-show graph-area))
      ;;
      ;; Simple quit button.
      ;;
      (let1 button (gtk-button-new-with-label "Quit")
        (gtk-box-pack-start vbox button #f #f 0)
        (g-signal-connect button "clicked" (lambda _ (gtk-main-quit)))
        (gtk-widget-show button))
      )
    (gtk-widget-show window)
    (gtk-main)
    0))
 
;; create a simple graph
(define (graph-build-simple graph)
  (glgd-graph-init graph)
  (let* ((model (glgd-node-create))
         (geometry (glgd-node-create))
         (torso (glgd-node-create))
         (arms (glgd-node-create))
         (legs (glgd-node-create))
         (skeleton (glgd-node-create))
         (hip (glgd-node-create))
         (thighLeft (glgd-node-create))
         (thighRight (glgd-node-create)))
    (glgd-node-info-set model "model" 0)
    (glgd-node-attribute-set model *attr-geometry*)
    (glgd-node-info-set geometry "geometry" 1)
    (glgd-node-attribute-set geometry *attr-geometry*)
    (glgd-node-info-set skeleton "skeleton" 2)
    (glgd-node-attribute-set skeleton *attr-skeleton*)
    (glgd-node-info-set torso "torso" 3)
    (glgd-node-attribute-set torso *attr-geometry*)
    (glgd-node-info-set arms "arms" 4)
    (glgd-node-attribute-set arms *attr-geometry*)
    (glgd-node-info-set legs "legs" 5)
    (glgd-node-attribute-set legs *attr-geometry*)
    (glgd-node-info-set hip "hip" 6)
    (glgd-node-attribute-set hip *attr-skeleton*)
    (glgd-node-info-set thighLeft "thighLeft" 7)
    (glgd-node-attribute-set thighLeft *attr-skeleton*)
    (glgd-node-info-set thighRight "thighRight" 8)
    (glgd-node-attribute-set thighRight *attr-skeleton*)
    (glgd-graph-node-add graph model)
    (glgd-graph-node-add graph geometry)
    (glgd-graph-node-add graph skeleton)
    (glgd-graph-node-add graph torso)
    (glgd-graph-node-add graph arms)
    (glgd-graph-node-add graph legs)
    (glgd-graph-node-add graph hip)
    (glgd-graph-node-add graph thighLeft)
    (glgd-graph-node-add graph thighRight)
    (let* ((list (glgd-link-list-create))
           (m2g (glgd-link-create))
           (g2t (glgd-link-create))
           (g2a (glgd-link-create))
           (g2l (glgd-link-create))
           (m2s (glgd-link-create))
           (s2h (glgd-link-create))
           (h2tl (glgd-link-create))
           (h2tr (glgd-link-create))
           (tr2h (glgd-link-create))
           (tr2s (glgd-link-create)))
      (glgd-link-set m2g model geometry)
      (glgd-link-set g2t geometry torso)
      (glgd-link-set g2a geometry arms)
      (glgd-link-set g2l geometry legs)
      (glgd-link-set m2s model skeleton)
      (glgd-link-set s2h skeleton hip)
      (glgd-link-set h2tl hip thighLeft)
      (glgd-link-set h2tr hip thighRight)
      (glgd-link-set tr2h thighRight hip)
      (glgd-link-set tr2s thighRight skeleton)
      (glgd-graph-link-add graph list m2g)
      (glgd-graph-link-add graph list m2s)
      (glgd-graph-link-add graph list g2t)
      (glgd-graph-link-add graph list g2a)
      (glgd-graph-link-add graph list g2l)
      (glgd-graph-link-add graph list s2h)
      (glgd-graph-link-add graph list h2tl)
      (glgd-graph-link-add graph list h2tr)
      (glgd-graph-link-add graph list tr2h)
      (glgd-graph-link-add graph list tr2s)
      (glgd-graph-link-list-add graph list)))
  (glgd-graph-attribute-set graph *attr-current*)
  (glgd-graph-auto-organize graph 0.0 0.0)
  (glgd-graph-link-list-dump graph)
  #t)
 

Title: Re: Gauche Scheme
Post by: Mike Lobanovsky on January 19, 2015, 12:19:10 AM

Despite the apparent complexity, the gears example isn't very representative of software throughput.

Below is a snapshot of gears example running in Fabrice Bellard's (he's the author of Tiny C Compiler, the engine behind FBSL Dynamic C) TinyGL software renderer under KolibriOS within the VMware Player virtual machine.

TinyGL is a tiny subset of OpenGL-like API reimplemented with the aid of pure GDI calls. KolibriOS is an absolutely tiny open-source non-Linux indie graphical operating system written in pure assembly; its basic distro w/o the game set fits on a 1.44MB floppy disk! KolibriOS's graphics doesn't enjoy any hardware acceleration either.

Yet watch the absolutely amazing FPS rate of this example in a KolibryOS TinyGL window.

.

Title: Re: Gauche Scheme
Post by: RobbeK on January 19, 2015, 11:34:02 AM

Thanks, John Mike for all this interesting stuff !!

John - up to date with your specs now -- (some small problems with the libutils (seems to be libutils-gold that I needed ).
Great, I can "mouse wheel" into the widgets.
Can't get DynLoad package working , but the C-Wrapper is working

gosh> (use c-wrapper)
#<undef>
gosh> (c-load "stdio.h")
#<undef>
gosh> (printf "Hello \n")
Hello
7
gosh> :) -- great stuff,

thanks !!

Title: Re: Gauche Scheme
Post by: JRS on January 19, 2015, 12:41:45 PM

I'm glad we both found something we like and can work together on.

Let me know what the issues are and I'll take a shot and finding a solution. Worse case we can beg Mike to help. ;D

Title: Re: Gauche Scheme
Post by: Mike Lobanovsky on January 19, 2015, 04:08:37 PM

Mike bad, Mike angry, Mike eat little kids for supper! :'(

;D

Title: Re: Gauche Scheme
Post by: JRS on January 19, 2015, 08:48:25 PM

No!

You translated that incorrectly.

(http://lowres.jantoo.com/religion-hospitalized-clinics-injury-accidents-hospital-19031035_low.jpg)

Title: Re: Gauche Scheme
Post by: RobbeK on January 23, 2015, 02:56:49 AM

John , all ,

tk/tcl is very easy to set up on Gauche and newLISP ( http://www.tcl.tk/ ). Linux already comes with it (be it a somewhat older version) , easy to install under Win and Mac. There's a package for the CL compilers CLISP , Clozure , Steel Bank , CMUCL , ECL , Mankay etc..
In newLISP and Gauche there's even no need to compile anything , just setting up the pipes :

(map set '(myin tcout) (pipe))
(map set '(tcin myout) (pipe))
(process "/usr/bin/wish" tcin tcout)

;; passing the commands
(define (tk)
(write-line myout (append "if { [catch { puts ["
(apply string (args)) "] }] } { "
[text] tk_messageBox -message $errorInfo; exit }
[/text]))

and the listener :
(while (read-line myin)
(eval-string (current-line)))

tk data can be read p.e.

(tk "set A_tcl_variable something")
and caught by newLisp
(setq a-newlisp-variable (tk "puts $A_tcl_variable"))
................ complete interactive, both scripts (lisp+tcl) can be mixed in the code !!

p.e. (tk (append ".............. tcl code .................. " (string (.............. lisp code ..............)) .... etc ........... ))

any number of call-backs can be set up easily

I also could set up OpenGL , glut under newLISP - a newLISP standalone exec should be less than 300 Kb + characters of the code 8)
(working on standalone Gauche distro's , but they are a lot fatter , more later )

best Rob

attached 2x newLISP
- swarm , tk + newLISP (no widgets here, but those are easy to set up)
- gprimes , Gaussprimes , OpenGL + newLISP
Linux only / you will probably have to set the permissions before running.

addendum : added wineswarm.exe -- same code, bundled under Wine for Win -- however it expects the exact c:\tcl\bin\wish.exe location (the standard installation of tk/tcl under Win). -- (infact the code can be written in a universal way where the code reads the OS and sets the respec. definition ).

for the OpenGL , libGL.so , libglut.so should be in your /usr/lib

.

Title: Re: Gauche Scheme
Post by: JRS on January 23, 2015, 08:52:10 AM

Thanks Rob for the Gauche update. I'm glad you're having so much fun. :)

Title: Re: Gauche Scheme
Post by: RobbeK on January 27, 2015, 07:12:30 AM

OK , some Gauche then ... 1st code .. (2D skeleton, stolen from the examples ;)

a test, iteration and recursion seem to run at the same speed

(use gl)
(use gl.glut)

(define (init)
(gl-clear-color 0.0 0.0 0.0 0.0)
(gl-shade-model GL_SMOOTH))

(define (sq x) (* x x))

(define (julia x y rc ic maxiter it orb) ;; recursion
(if (or (= it maxiter) (> orb 4.0)) it
(julia (+ (- (sq x) (sq y)) rc) (+ ic (* 2.0 x y)) rc ic maxiter (+ it 1) (abs (* y x)) )
))

(define (julia-it x y rc ic maxiter) ;; iteration
(let (( it 0) (orb 0) (tmp 0) )
(while (and (< it maxiter) (< orb 4.0))
(set! tmp x)
(set! x (+ rc (- (sq x) (sq y))))
(set! y (+ ic (* 2.0 tmp y)))
(inc! it)
(set! orb (abs (* x y))) )
it ))

(define (fractal)

(gl-begin GL_POINTS)
(do ((i -2.5 (+ i 0.008)))
((> i 1.5))
(do ((j -2.0 (+ j 0.008)))
((> j 2.0))
(let ((k (/ (julia i j i j 16 0 0.0) 16.0)))
(gl-color 0.0 k 0.0)
)
(gl-vertex i j) ))
(gl-end))

(define (disp)
(gl-clear GL_COLOR_BUFFER_BIT)
(fractal)
(gl-flush)
)

(define (reshape w h)
(gl-viewport 0 0 w h)
(gl-matrix-mode GL_PROJECTION)
(gl-load-identity)
(glu-ortho-2d -2.5 1.5 -2.0 2.0)
(gl-matrix-mode GL_MODELVIEW)
)

(define (keyboard key x y)
(when (= key 27) (exit 0)))

(define (main args)
(glut-init args)
(glut-init-display-mode (logior GLUT_SINGLE GLUT_RGB))
(glut-init-window-size 500 500)
(glut-init-window-position 100 100)
(glut-create-window "JULIA - MANDELBROT")
(init)
(gl-clear GL_COLOR_BUFFER_BIT)
(gl-flush)
(glut-display-func disp)
(glut-reshape-func reshape)
(glut-keyboard-func keyboard)

(glut-main-loop)
0)

both scripts attached

best Rob (surface about 3x bigger than what came with the examples)

(jullia x y x y .... ) is identical with a (mandelbrot x y ...... )
this formula does both p.e. (julia x y 0.0 -1.0 .... ) is the dendrithe (?not correct anglais i think)

.

Title: Re: Gauche Scheme
Post by: JRS on January 27, 2015, 09:11:15 AM

Thanks Rob!

You're right. I can't see any difference between the iteration and recursion versions.

Either way it's FAST.

Note: My tests are running on Ubuntu in true 64 bit while Rob is running on a 32 bit version of Linux.

.

Title: Re: Gauche Scheme
Post by: RobbeK on January 27, 2015, 11:28:44 AM

Hi John,

Can even be sped up ..
An advantage of lisp (in general) is that one does not need to set up UDT's to return composite values of functions , changed the code a little and the Julia (recursive ) gives back a list with both the orbit value and the number of iterations , here the orbit is used for the greens .

(julia .... ) -> (list it orb) :: car -> iteration escape level :: cadr -> orbit escape level.

the knowledge about the performance of recursion is important (to me), because very often math. formulae are easier expressed by recursion , program flow certainly not ;)

best Rob

addendum : added fastMandel2.scm calculates the orbit the classic way by its distance to (0,0) (infact it does the square of the distance ::: x²+y² -- the speed is remarkable for a scripting language (imho)

.

Title: Re: Gauche Scheme
Post by: JRS on January 27, 2015, 01:04:53 PM

Quote

the speed is remarkable for a scripting language

The difference between an interpreter and compiler in many cases is you don't have to look at ugly with the interpreter. :o

Title: Re: Gauche Scheme
Post by: JRS on January 27, 2015, 04:32:23 PM

Very Nice!

It displayed instantly here so I can't see what a compiler brings to the table.

Code: Scheme

(use gl)
(use gl.glut)
 
(define (init)
  (gl-clear-color 0.0 0.0 0.0 0.0)
  (gl-shade-model GL_SMOOTH))
 
(define (sq x) (* x x))
 
(define (julia x y rc ic maxiter it orb)
  (if (or (= it maxiter) (> orb 4.0)) (list it orb)
    (julia (+ (- (sq x) (sq y)) rc) (+ ic (* 2.0 x y)) rc ic maxiter (+ it 1) (+ (sq x) (sq y)) )
))
 
(define (julia-it x y rc ic maxiter)
  (let (( it 0) (orb 0) (tmp 0) )
    (while (and (< it maxiter) (< orb 4.0))
      (set! tmp x)
      (set! x (+ rc (- (sq x) (sq y))))
      (set! y (+ ic (* 2.0 tmp y)))
      (inc! it)
      (set! orb (abs (* x y))) )
 it ))
 
(define (fractal)
  
  (gl-begin GL_POINTS)
   (do ((i -2.5 (+ i 0.008)))
       ((> i 1.5))
    (do ((j -2.0 (+ j 0.008)))
        ((> j 0.0))
  (let* ((info (julia i j i j 17 0 0.0))
         (k (/ (car info) 17.0))
         (orb (cadr info)  ))
  
   (gl-color  (sq k) (/ 1.8 orb) 0.1)
    )
   (gl-vertex  i j)
   (gl-vertex i (- (abs j) 0.008)  )))
   (gl-end))
 
 
(define (disp)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (fractal)
  (gl-flush)
  )
 
(define (reshape w h)
  (gl-viewport 0 0 w h)
  (gl-matrix-mode GL_PROJECTION)
  (gl-load-identity)
      (glu-ortho-2d -2.5 1.5 -2.0 2.0)
  (gl-matrix-mode GL_MODELVIEW)
  )
 
(define (keyboard key x y)
  (when (= key 27) (exit 0)))
 
(define (main args)
  (glut-init args)
  (glut-init-display-mode (logior GLUT_SINGLE GLUT_RGB))
  (glut-init-window-size 500 500)
  (glut-init-window-position 100 100)
  (glut-create-window "JULIA - MANDELBROT")
  (init)
  (gl-clear GL_COLOR_BUFFER_BIT)
  (gl-flush)
  (glut-display-func disp)
  (glut-reshape-func reshape)
  (glut-keyboard-func keyboard)
   
  (glut-main-loop)
  0)
 

Title: Re: Gauche Scheme
Post by: Mike Lobanovsky on January 27, 2015, 07:30:17 PM

Hi Rob,

The uglyest looking Mandelbrot presentation I ever saw. All made up of taste buds on the tongue of a little green alien.

(http://www.oxygenbasic.org/forum/index.php?action=dlattach;topic=1271.0;attach=3837)

Some light at the end of the tunnel.

(http://www.oxygenbasic.org/forum/index.php?action=dlattach;topic=1271.0;attach=3840)

;D

Title: Re: Gauche Scheme
Post by: RobbeK on January 28, 2015, 06:22:25 AM

Hi John, Mike

the ugliest , yep , quickly changed into the tunnel view ;)

Tested the complex numbers now : working with complex numbers always slows down things - but writing a complex 4th degree function in x, y takes some time on paper (while not difficult). (see attachment , also including Sin(z²) ) speed is still very good.
The whole Mandelbrot/Julia simplifies into

(define (juliaC z c maxiter it orb)
(if (or (= it maxiter) (> orb 4.0)) (list it orb)
(juliaC (+ (* z z) c) c maxiter (+ it 1) (abs (* z z)))))

Tk/Tcl is working too now -- just (John) do you find any info on any kind of FFI ?? (there are some texts in Japanese , but ;..)

best Rob

.

Title: Re: Gauche Scheme
Post by: JRS on January 28, 2015, 09:58:55 AM

Hi Rob,

Can you try this FFI extension for Gauche?

c-wrapper - A Generic Wrapper for C Libraries (http://www.koguro.net/prog/c-wrapper/)

Let me know how it goes.

Title: Re: Gauche Scheme
Post by: JRS on January 28, 2015, 01:06:02 PM

The c-wrapper library compiled for me and was able to run the Breakout SDL example.

Code: Scheme

;; -*- coding: utf-8; mode: scheme -*-
;;
;; breakout.scm - Breakout
;;
;;   Copyright (c) 2007 KOGURO, Naoki (naoki@koguro.net)
;;   All rights reserved.
;;
;;   Redistribution and use in source and binary forms, with or without 
;;   modification, are permitted provided that the following conditions 
;;   are met:
;;
;;   1. Redistributions of source code must retain the above copyright 
;;      notice, this list of conditions and the following disclaimer.
;;   2. Redistributions in binary form must reproduce the above copyright 
;;      notice, this list of conditions and the following disclaimer in the 
;;      documentation and/or other materials provided with the distribution.
;;   3. Neither the name of the authors nor the names of its contributors 
;;      may be used to endorse or promote products derived from this 
;;      software without specific prior written permission.
;;
;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 
;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 
;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;
;;   $Id: $
;;
 
(use c-wrapper)
(use srfi-1)
(use srfi-27)
 
(c-load '("SDL.h" "SDL_mixer.h" "stdio.h" "stdlib.h" "sdl_helper.c")
        :cppflags-cmd "sdl-config --cflags"
        :libs-cmd "sdl-config --libs; echo '-lSDL_mixer'"
        :import (list (lambda (header sym)
                        (#/\/SDL\/.*\.h$/ header))
                      'NULL
                      'run_sdl_main)
        :compiled-lib "sdllib")
 
(define *screen* #f)
(define-constant *screen-width* 640)
(define-constant *screen-height* 480)
(define-constant *screen-depth* 8)
(define *unit* 8)
 
(define *ball-rect* #f)
;; vx and vy must be a multiple of *unit*.
(define *ball-vx* 0)
(define *ball-vy* 0)
(define *ball-count* 0)
(define-constant *ball-size* *unit*)
 
(define *paddle-rect* #f)
(define *paddle-width* (* 8 *unit*))
(define *paddle-vx* 0)
 
(define *block-list* '())
(define *block-start-x* 0)
(define *block-start-y* 0)
(define *block-end-x* 0)
(define *block-end-y* 0)
 
(define-constant *block-width* (* 6 *unit*))
(define-constant *block-height* (* 3 *unit*))
 
(define *tick* 0)
(define *tick-threshold* 20)
 
(define *bounce-sound* #f)
(define *shoot-sound* #f)
 
(define (init)
  (SDL_Init (logior SDL_INIT_VIDEO SDL_INIT_AUDIO))
  (set! *screen* (SDL_SetVideoMode *screen-width* *screen-height*
                                   *screen-depth*
                                   (logior SDL_HWSURFACE
                                           SDL_DOUBLEBUF)))
  (SDL_WM_SetCaption "Breakout" NULL)
  (set! *paddle-rect* (make <SDL_Rect>))
  (set! (ref *paddle-rect* 'w) *paddle-width*)
  (set! (ref *paddle-rect* 'h) *unit*)
  
  (Mix_OpenAudio 44100 AUDIO_S16SYS 2 1024)
  (set! *bounce-sound* (Mix_LoadWAV "cursor5.wav"))
  (set! *shoot-sound* (Mix_LoadWAV "cursor6.wav"))
  (init-game))
 
(define (init-game)
  (set! (ref *paddle-rect* 'x) (- (/ *screen-width* 2)
                                  (/ (ref *paddle-rect* 'w) 2)))
  (set! (ref *paddle-rect* 'y) (- *screen-height* (* 3 *unit*)))
  (set! *ball-count* 2)
  (make-blocks))
  
(define (make-block x y color)
  (let ((rect (make <SDL_Rect>)))
    (set! (ref rect 'x) (+ x 1))
    (set! (ref rect 'y) (+ y 1))
    (set! (ref rect 'w) (- *block-width* 2))
    (set! (ref rect 'h) (- *block-height* 2))
  (vector (list x y (+ x *block-width*) (+ y *block-height*))
          rect
          color)))
 
(define (block-vertical-reflect? block x y vx)
  (receive (sx sy ex ey) (apply values (vector-ref block 0))
    (and (<= sy y ey)
         (or (and (= x sx) (< 0 vx))
             (and (= x ex) (< vx 0))))))
 
(define (block-horizontal-reflect? block x y vy)
  (receive (sx sy ex ey) (apply values (vector-ref block 0))
    (and (<= sx x ex)
         (or (and (= y sy) (< 0 vy))
             (and (= y ey) (< vy 0))))))
 
(define (block-hit? block x y)
  (receive (sx sy ex ey) (apply values (vector-ref block 0))
    (and (<= sx x ex) (<= sy y ey))))
  
(define (make-blocks)
  (do ((block-list '())
       (level 0 (+ level 1))
       (colors '(#o700 #o770 #o373 #o077 #o007) (cdr colors))
       (y (* 7 *unit*) (+ y *block-height*)))
      ((<= 5 level)
       (set! *block-list* block-list))
    (do ((x (* 1 *unit*) (+ x *block-width*)))
        ((<= *screen-width* (+ x *block-width*)))
      (push! block-list (make-block x y (car colors)))))
  (set! *block-start-x* *screen-width*)
  (set! *block-start-y* *screen-height*)
  (set! *block-end-x* 0)
  (set! *block-end-y* 0)
  (for-each (lambda (block)
              (receive (sx sy ex ey) (apply values (vector-ref block 0))
                (when (< sx *block-start-x*)
                  (set! *block-start-x* sx))
                (when (< sy *block-start-y*)
                  (set! *block-start-y* sy))
                (when (< *block-end-x* ex)
                  (set! *block-end-x* ex))
                (when (< *block-end-y* ey)
                  (set! *block-end-y* ey))))
            *block-list*))
                
(define (teardown)
  (Mix_CloseAudio)
  (SDL_Quit))
 
(define clear-screen
  (let ((rect (make <SDL_Rect>)))
    (set! (ref rect 'x) 0)
    (set! (ref rect 'y) 0)
    (set! (ref rect 'w) *screen-width*)
    (set! (ref rect 'h) *screen-height*)
    (lambda ()
      (SDL_FillRect *screen* (ptr rect) 0))))
  
(define (draw-paddle)
  (SDL_FillRect *screen* (ptr *paddle-rect* ) #o777))
 
(define (move-paddle-left)
  (set! *paddle-vx* (- *unit*)))
 
(define (move-paddle-right)
  (set! *paddle-vx* *unit*))
 
(define (move-paddle)
  (let ((new-x (+ (ref *paddle-rect* 'x) *paddle-vx*))
        (w (ref *paddle-rect* 'w)))
    (when (< new-x 0)
      (set! new-x 0))
    (when (< (- *screen-width* w) new-x)
      (set! new-x (- *screen-width* w)))
    (set! (ref *paddle-rect* 'x) new-x)))
 
(define (stop-paddle)
  (set! *paddle-vx* 0))
 
(define (draw-ball)
  (when *ball-rect*
    (SDL_FillRect *screen* (ptr *ball-rect*) #o777)))
 
(define (move-ball)
  (let ((reflect? #f))
    (define (reflect-x)
      (set! *ball-vx* (- *ball-vx*))
      (set! reflect? #t))
    (define (reflect-y)
      (set! *ball-vy* (- *ball-vy*))
      (set! reflect? #t))
    (when *ball-rect*
      (let ((new-x (+ (ref *ball-rect* 'x) *ball-vx*))
            (new-y (+ (ref *ball-rect* 'y) *ball-vy*))
            (paddle-x (ref *paddle-rect* 'x))
            (paddle-y (ref *paddle-rect* 'y))
            (paddle-w (ref *paddle-rect* 'w))
          (paddle-h (ref *paddle-rect* 'h))
          (w (ref *ball-rect* 'w))
          (h (ref *ball-rect* 'h)))
        (when (< new-x 0)
          (reflect-x)
          (set! new-x (- new-x)))
        (when (< (- *screen-width* w) new-x)
          (reflect-x)
          (set! new-x (- (* 2 (- *screen-width* w)) new-x)))
        (when (< new-y 0)
          (reflect-y)
          (set! new-y 0))
        (when (and (<= paddle-y new-y (+ paddle-y paddle-h))
                   (<= paddle-x new-x (+ paddle-x paddle-w)))
          (reflect-y)
          (when (or (and (= paddle-x new-x)
                         (< 0 *ball-vx*))
                    (and (= (+ paddle-x paddle-w (- *unit*)) new-x)
                         (< *ball-vx* 0)))
            (reflect-x))
          (set! new-y (- paddle-y h)))
        (when (< (- *screen-height* h) new-y)
          (dec! *ball-count*)
          (set! *ball-rect* #f))
        (when (and (<= *block-start-x* new-x *block-end-x*)
                   (<= *block-start-x* new-y *block-end-y*))
          (do ((block-list *block-list* (cdr block-list))
               (result '() (cons (car block-list) result)))
              ((or (null? block-list)
                   (block-hit? (car block-list) new-x new-y))
               (unless (null? block-list)
                 (when (block-vertical-reflect? (car block-list) new-x new-y
                                                *ball-vx*)
                   (reflect-x))
                 (when (block-horizontal-reflect? (car block-list) new-x new-y
                                                  *ball-vy*)
                   (reflect-y))
                 (set! *block-list* (append result (cdr block-list)))))))
        (when *ball-rect*
          (set! (ref *ball-rect* 'x) new-x)
          (set! (ref *ball-rect* 'y) new-y))
        (when reflect?
          (Mix_PlayChannel -1 *bounce-sound* 0))))))
 
(define (shoot-ball)
  (unless *ball-rect*
    (let ((paddle-x (ref *paddle-rect* 'x))
          (paddle-y (ref *paddle-rect* 'y))
          (paddle-w (ref *paddle-rect* 'w))
          (paddle-h (ref *paddle-rect* 'h)))
      (set! *ball-rect* (make <SDL_Rect>))
      (set! (ref *ball-rect* 'w) *ball-size*)
      (set! (ref *ball-rect* 'h) *ball-size*)
      (set! (ref *ball-rect* 'x) (+ paddle-x (/ paddle-w 2)))
      (set! (ref *ball-rect* 'y) paddle-y)
      (set! *ball-vx* (* (- (* 2 (random-integer 2)) 1) *unit*))
      (set! *ball-vy* (- *unit*))
      (format #t "ball: ~a~%" *ball-count*)
      (Mix_PlayChannel -1 *shoot-sound* 0))))
 
(define (draw-blocks)
  (for-each (lambda (block)
              (SDL_FillRect *screen*
                            (ptr (vector-ref block 1))
                            (vector-ref block 2)))
            *block-list*))
 
(define (poll-event event)
  (SDL_PollEvent (ptr event))
  (unless (< 0 (SDL_PollEvent (ptr event)))
    (let ((type (ref event 'type)))
      (cond
       ((eq? type SDL_QUIT)
        #f)
       ((eq? type SDL_KEYDOWN)
        (case (ref* event 'key 'keysym 'sym)
          ((27)
           #f)
          ((32)
           (shoot-ball)
           #t)
          ((122)
           (move-paddle-left)
           #t)
          ((120)
           (move-paddle-right)
           #t)
          (else
           #t)))
       (else
        #t)))))
 
(define (sdl-main argc argv)
  (init)
  (let ((event (make <SDL_Event>)))
    (do ((continue? (poll-event event) (poll-event event)))
        ((not continue?) #f)
      (clear-screen)
      (move-paddle)
      (let ((delta (- (SDL_GetTicks) *tick*)))
        (when (< *tick-threshold* delta)
          (move-ball)
          (set! *tick* (SDL_GetTicks))))
      (draw-paddle)
      (draw-ball)
      (draw-blocks)
      (stop-paddle)
      (SDL_Flip *screen*)
      (cond
       ((< *ball-count* 0)
        (print "GAME OVER!!")
        (init-game))
       ((null? *block-list*)
        (set! *ball-rect* #f)
        (make-blocks)))))
  (teardown)
  0)
  
(define (main args)
  (run_sdl_main (length args) args sdl-main))
  
;; end of file
 

Title: Re: Gauche Scheme
Post by: RobbeK on January 28, 2015, 01:28:57 PM

Hi John,

No success here , tells me libc.so.6 is not present in /libx32... , while it is there both in /libx32 and /usr/libx32 ..somewhat annoying
There is a lazy-ffi I found on a Jap site , but it also gives an error (reported (recently) by others - this code is 8 yrs. old and seemed to work in the past) trying DynComp now

best Rob

Title: Re: Gauche Scheme
Post by: JRS on January 28, 2015, 01:39:21 PM

FWIW - I use the --prefix=/usr for all my 64 bit package builds.

Code: [Select]

./configure --prefix=/usr
make
sudo make install

Title: Re: Gauche Scheme
Post by: JRS on January 28, 2015, 08:27:31 PM

I thought I would run the testsuite examples but there were no compiled .so libraries, just source. The Makefile in the directory when run said nothing to be done. :-\

I compile the gcc_extension.c example manually so I could run the corresponding Gauche .scm example.

Code: C

#include "gcc_extension.h"
 
void inc_foo(struct foo *v, int mode)
{
    ++(v->a);
    switch (mode) {
    case FLOAT_MODE:
        ++(v->b);
        break;
    case STRUCT_MODE:
        ++(v->c);
        ++(v->d);
        break;
    default:
        break;
    }
    ++(v->e);
    ++(v->f);
    ++(v->g);
}
 

Code: Scheme

;;;
;;; Test GCC extension
;;; 
 
(use gauche.test)
 
(test-start "gcc_extension")
(use c-wrapper)
(test-module 'c-wrapper)
 
(c-load-library "./gcc_extension")
(c-include "./gcc_extension.h")
 
(test "Unnamed struct/union fields within structs/unions 1"
      '(2 3.0 4 5 6.0)
      (lambda ()
        (let ((foo (make (c-struct 'foo))))
          (set! (ref foo 'a) 1)
          (set! (ref foo 'b) 2)
          (set! (ref foo 'e) 3)
          (set! (ref foo 'f) 4)
          (set! (ref foo 'g) 5)
          (inc_foo (ptr foo) FLOAT_MODE)
          (map (cut ref foo <>) '(a b e f g)))))
 
(test "Unnamed struct/union fields within structs/unions 2"
      '(2 3 4.0 5 6 7.0)
      (lambda ()
        (let ((foo (make (c-struct 'foo))))
          (set! (ref foo 'a) 1)
          (set! (ref foo 'c) 2)
          (set! (ref foo 'd) 3)
          (set! (ref foo 'e) 4)
          (set! (ref foo 'f) 5)
          (set! (ref foo 'g) 6)
          (inc_foo (ptr foo) STRUCT_MODE)
          (map (cut ref foo <>) '(a c d e f g)))))
 
;; epilogue
(test-end)
 

jrs@laptop:~/c-wrapper/testsuite$ gcc gcc_extension.c -c -fPIC -o gcc_extension.o jrs@laptop:~/c-wrapper/testsuite$ gcc -shared gcc_extension.o -o gcc_extension.so jrs@laptop:~/c-wrapper/testsuite$ gosh gcc_extension-test.scm Testing gcc_extension ... testing bindings in #<module c-wrapper> ... ok test Unnamed struct/union fields within structs/unions 1, expects (2 3.0 4 5 6.0) ==> ok test Unnamed struct/union fields within structs/unions 2, expects (2 3 4.0 5 6 7.0) ==> ok passed. jrs@laptop:~/c-wrapper/testsuite$

Title: Re: Gauche Scheme
Post by: RobbeK on January 29, 2015, 01:56:16 AM

Hi John,

Some of the tests work, but the important

Testing c-wrapper (inline) ...
gosh: "error": can't load libc (/libx32/libc.so.6: cannot open shared object file: No such file or directory)

but , it's there and when I do a sudo apt-get install , it tells I have the most up to date version.
Does it expect the libc.so.6 tp be in another path ????

I rebuilt the packages the way you do it

./configure --prefix=/usr
make clean ............. etc

:-\ Rob

however, what i urgently need is this one :
http://quasiquote.org/log2/Scheme/Gauche/Gauche-lazy-ffi (libffi-dev is intalled, but can not get the lazy-ffi working for the moment)

but :

/usr/lib/gauche-0.9/site/i686-pc-linux-gnu/lazy-ffi.so: undefined symbol: strlcpy
"(stdin)":1:(use lazy-ffi)
..........................;

Title: Re: Gauche Scheme
Post by: JRS on January 29, 2015, 09:34:14 AM

Rob,

I was able to get the c-wrapper inline-test.scm example to work. I had to use the full path for libc.so.6 and compile ffitest.so.

Code: Scheme

;;;
;;; inline function test
;;;
 
(use gauche.test)
 
(test-start "c-wrapper (inline)")
(use c-wrapper)
 
(c-load-library "/lib/x86_64-linux-gnu/libc.so.6")
(c-load-library "./ffitest")
(c-include '("stdio.h" "stdlib.h" "./ffitest.h"))
 
(test "constant"
      1
      (lambda ()
        (return_const)))
 
(test "string"
      "foo"
      (lambda ()
        (x->string (return_string))))
 
(test "ref array"
      10
      (lambda ()
        (let ((a (make (c-array <c-int> 3))))
          (set! (ref a 0) 0)
          (set! (ref a 1) 10)
          (set! (ref a 2) 20)
          (ref_array a))))
 
(test "func call without argument"
      '(-2 -1 0 1 2)
      (lambda ()
        (funccall1)
        (list (ref test_array 0)
              (ref test_array 1)
              (ref test_array 2)
              (ref test_array 3)
              (ref test_array 4))))
 
(test "func call with arguments"
      3
      (lambda ()
        (funcall2 1 2)))
 
(test "ref struct (. operator)"
      1
      (lambda ()
        (ref_struct1)))
 
(test "ref struct (-> operator)"
      1
      (lambda ()
        (let ((a (make (c-struct 'test_sint))))
          (set! (ref a 'value) 1)
          (ref_struct2 (ptr a)))))
 
 
(test "post increment"
      2
      (lambda ()
        (post_inc)))
 
(test "post decrement"
      1
      (lambda ()
        (post_dec)))
 
(test "pre increment"
      2
      (lambda ()
        (pre_inc)))
 
(test "pre decrement"
      1
      (lambda ()
        (pre_dec)))
 
(test "unary plus"
      1
      (lambda ()
        (unary_plus)))
 
(test "unary minus"
      -1
      (lambda ()
        (unary_minus)))
 
(test "unary logical negation"
      '(0 1)
      (lambda ()
        (list (unary_logneg 1) (unary_logneg 0))))
 
(test "unary bitwise negation"
      -2
      (lambda ()
        (unary_bitneg 1)))
 
(test "unary reference"
      123
      (lambda ()
        (unary_ref)))
 
(test "unary dereference"
      456
      (lambda ()
        (ref (deref (unary_deref)))))
 
(test "sizeof"
      #t
      (lambda ()
        (eq? (c-sizeof <c-int>) (op_sizeof))))
 
(test "mul"
      6
      (lambda ()
        (mul 2 3)))
 
(test "divi"
      3
      (lambda ()
        (divi 18 6)))
 
(test "mod"
      1
      (lambda ()
        (mod 5 2)))
 
(test "add"
      3
      (lambda ()
        (add 1 2)))
 
(test "sub"
      -1
      (lambda ()
        (sub 1 2)))
 
(test "left shift"
      4
      (lambda ()
        (left_shift 1 2)))
 
(test "right shift"
      2
      (lambda ()
        (right_shift 8 2)))
 
(test "lesser than"
      '(1 0 0)
      (lambda  ()
        (list (op_lt 1 2) (op_lt 2 2) (op_lt 2 1))))
 
(test "greater than"
      '(0 0 1)
      (lambda  ()
        (list (op_gt 1 2) (op_gt 2 2) (op_gt 2 1))))
 
(test "lesser than or equal" 
      '(1 1 0)
      (lambda  ()
        (list (op_lteq 1 2) (op_lteq 2 2) (op_lteq 2 1))))
 
(test "greater than or equal"
      '(0 1 1)
      (lambda  ()
        (list (op_gteq 1 2) (op_gteq 2 2) (op_gteq 2 1))))
 
(test "equal"
      '(0 1 0)
      (lambda  ()
        (list (op_eq 1 2) (op_eq 2 2) (op_eq 2 1))))
 
(test "not equal"
      '(1 0 1)
      (lambda  ()
        (list (op_noteq 1 2) (op_noteq 2 2) (op_noteq 2 1))))
 
(test "bitwise and"
      1
      (lambda ()
        (bitand 11 5)))
 
(test "bitwise or"
      15
      (lambda ()
        (bitor 11 5)))
 
(test "bitwise xor"
      14
      (lambda ()
        (bitxor 11 5)))
 
(test "logical and"
      '(1 0 0 0)
      (lambda ()
        (list (op_logand 1 1 1)
              (op_logand 1 1 0)
              (op_logand 0 1 1)
              (op_logand 0 1 0))))
 
(test "logical or"
      '(1 1 1 0)
      (lambda ()
        (list (op_logor 1 1 1)
              (op_logor 1 1 0)
              (op_logor 0 1 1)
              (op_logor 0 1 0))))
 
(test "assign mul"
      6
      (lambda ()
        (assign_mul 2 3)))
 
(test "assign div"
      3
      (lambda ()
        (assign_div 18 6)))
 
(test "assign mod"
      1
      (lambda ()
        (assign_mod 5 2)))
 
(test "assign_add"
      3
      (lambda ()
        (assign_add 1 2)))
 
(test "assign_sub"
      -1
      (lambda ()
        (assign_sub 1 2)))
 
(test "assign left shift"
      4
      (lambda ()
        (assign_left_shift 1 2)))
 
(test "assign right shift"
      2
      (lambda ()
        (assign_right_shift 8 2)))
 
(test "assign bitwise and"
      1
      (lambda ()
        (assign_bitand 11 5)))
 
(test "assign bitwise or"
      15
      (lambda ()
        (assign_bitor 11 5)))
 
(test "assign bitwise xor"
      14
      (lambda ()
        (assign_bitxor 11 5)))
 
(test "multi expr"
      10
      (lambda ()
        (multi_expr 2 5)))
 
(test "while"
      55
      (lambda ()
        (test_while)))
               
(test "while break"
      55
      (lambda ()
        (test_while_break)))
               
(test "while continue"
      55
      (lambda ()
        (test_while_continue)))
               
(test "do while"
      55
      (lambda ()
        (test_dowhile)))
               
(test "do while break"
      55
      (lambda ()
        (test_dowhile_break)))
               
(test "do while continue"
      0
      (lambda ()
        (test_dowhile_continue)))
               
(test "for"
      55
      (lambda ()
        (test_for)))
               
(test "for noinit, notest, noupdate"
      55
      (lambda ()
        (test_for_noinit_notest_noupdate)))
               
(test "for noinit, notest"
      55
      (lambda ()
        (test_for_noinit_notest)))
               
(test "for noinit, noupdate"
      55
      (lambda ()
        (test_for_noinit_noupdate)))
               
(test "for noinit"
      55
      (lambda ()
        (test_for_noinit_noupdate)))
 
(test "for notest, noupdate"
      55
      (lambda ()
        (test_for_notest_noupdate)))
               
(test "for notest"
      55
      (lambda ()
        (test_for_notest)))
               
(test "for noupdate"
      55
      (lambda ()
        (test_for_noupdate)))
 
(test "offset"
      #t
      (lambda ()
        (eq? (offset_calc) (c-offsetof (c-struct 'test_uchar) 'value))))
 
(test "not_supported"
      #t
      (lambda ()
        (procedure? not_supported)))
 
;; epilogue
(test-end)
 

jrs@laptop:~/c-wrapper/testsuite$ gosh inline-test.scm Testing c-wrapper (inline) ... test constant, expects 1 ==> ok test string, expects "foo" ==> ok test ref array, expects 10 ==> ok test func call without argument, expects (-2 -1 0 1 2) ==> ok test func call with arguments, expects 3 ==> ok test ref struct (. operator), expects 1 ==> ok test ref struct (-> operator), expects 1 ==> ok test post increment, expects 2 ==> ok test post decrement, expects 1 ==> ok test pre increment, expects 2 ==> ok test pre decrement, expects 1 ==> ok test unary plus, expects 1 ==> ok test unary minus, expects -1 ==> ok test unary logical negation, expects (0 1) ==> ok test unary bitwise negation, expects -2 ==> ok test unary reference, expects 123 ==> ok test unary dereference, expects 456 ==> ok test sizeof, expects #t ==> ok test mul, expects 6 ==> ok test divi, expects 3 ==> ok test mod, expects 1 ==> ok test add, expects 3 ==> ok test sub, expects -1 ==> ok test left shift, expects 4 ==> ok test right shift, expects 2 ==> ok test lesser than, expects (1 0 0) ==> ok test greater than, expects (0 0 1) ==> ok test lesser than or equal, expects (1 1 0) ==> ok test greater than or equal, expects (0 1 1) ==> ok test equal, expects (0 1 0) ==> ok test not equal, expects (1 0 1) ==> ok test bitwise and, expects 1 ==> ok test bitwise or, expects 15 ==> ok test bitwise xor, expects 14 ==> ok test logical and, expects (1 0 0 0) ==> ok test logical or, expects (1 1 1 0) ==> ok test assign mul, expects 6 ==> ok test assign div, expects 3 ==> ok test assign mod, expects 1 ==> ok test assign_add, expects 3 ==> ok test assign_sub, expects -1 ==> ok test assign left shift, expects 4 ==> ok test assign right shift, expects 2 ==> ok test assign bitwise and, expects 1 ==> ok test assign bitwise or, expects 15 ==> ok test assign bitwise xor, expects 14 ==> ok test multi expr, expects 10 ==> ok test while, expects 55 ==> ok test while break, expects 55 ==> ok test while continue, expects 55 ==> ok test do while, expects 55 ==> ok test do while break, expects 55 ==> ok test do while continue, expects 0 ==> ok test for, expects 55 ==> ok test for noinit, notest, noupdate, expects 55 ==> ok test for noinit, notest, expects 55 ==> ok test for noinit, noupdate, expects 55 ==> ok test for noinit, expects 55 ==> ok test for notest, noupdate, expects 55 ==> ok test for notest, expects 55 ==> ok test for noupdate, expects 55 ==> ok test offset, expects #t ==> ok test not_supported, expects #t ==> ok passed. jrs@laptop:~/c-wrapper/testsuite$

Title: Re: Gauche Scheme
Post by: RobbeK on January 29, 2015, 12:45:38 PM

Many thanks John :)

Testing c-wrapper (ffi) ...
testing bindings in #<module c-wrapper> ... ok
test dlopen, expects #f ==> ok
test dlsym, expects #f ==> ok
test ffi_prep_cif, expects 0 ==> ok
test ffi_call, expects 3 ==> ok
test ffi_closure, expects #t ==> ok
test call callback, expects 5 ==> ok
passed.
gerd@gerd-HP-Pavilion-dv4000-EK987EA-UUG:~/Downloads/c-wrapper-0.6.1/testsuite$ gosh inline-test.scm
Testing c-wrapper (inline) ...
test constant, expects 1 ==> ok
test string, expects "foo" ==> ok
test ref array, expects 10 ==> ok
test func call without argument, expects (-2 -1 0 1 2) ==> ok
test func call with arguments, expects 3 ==> ok
test ref struct (. operator), expects 1 ==> ok
test ref struct (-> operator), expects 1 ==> ok
test post increment, expects 2 ==> ok
test post decrement, expects 1 ==> ok
test pre increment, expects 2 ==> ok
test pre decrement, expects 1 ==> ok
test unary plus, expects 1 ==> ok
test unary minus, expects -1 ==> ok
test unary logical negation, expects (0 1) ==> ok
test unary bitwise negation, expects -2 ==> ok
test unary reference, expects 123 ==> ok
test unary dereference, expects 456 ==> ok
test sizeof, expects #t ==> ok
test mul, expects 6 ==> ok
test divi, expects 3 ==> ok
test mod, expects 1 ==> ok
test add, expects 3 ==> ok
test sub, expects -1 ==> ok
test left shift, expects 4 ==> ok
test right shift, expects 2 ==> ok
test lesser than, expects (1 0 0) ==> ok
test greater than, expects (0 0 1) ==> ok
test lesser than or equal, expects (1 1 0) ==> ok
test greater than or equal, expects (0 1 1) ==> ok
test equal, expects (0 1 0) ==> ok
test not equal, expects (1 0 1) ==> ok
test bitwise and, expects 1 ==> ok
test bitwise or, expects 15 ==> ok
test bitwise xor, expects 14 ==> ok
test logical and, expects (1 0 0 0) ==> ok
test logical or, expects (1 1 1 0) ==> ok
test assign mul, expects 6 ==> ok
test assign div, expects 3 ==> ok
test assign mod, expects 1 ==> ok
test assign_add, expects 3 ==> ok
test assign_sub, expects -1 ==> ok
test assign left shift, expects 4 ==> ok
test assign right shift, expects 2 ==> ok
test assign bitwise and, expects 1 ==> ok
test assign bitwise or, expects 15 ==> ok
test assign bitwise xor, expects 14 ==> ok
test multi expr, expects 10 ==> ok
test while, expects 55 ==> ok
test while break, expects 55 ==> ok
test while continue, expects 55 ==> ok
test do while, expects 55 ==> ok
test do while break, expects 55 ==> ok
test do while continue, expects 0 ==> ok
test for, expects 55 ==> ok
test for noinit, notest, noupdate, expects 55 ==> ok
test for noinit, notest, expects 55 ==> ok
test for noinit, noupdate, expects 55 ==> ok
test for noinit, expects 55 ==> ok
test for notest, noupdate, expects 55 ==> ok
test for notest, expects 55 ==> ok
test for noupdate, expects 55 ==> ok
test offset, expects #t ==> ok
test not_supported, expects #t ==> ok
passed.

great , Rob

Title: Re: Gauche Scheme
Post by: JRS on January 29, 2015, 01:22:02 PM

Can I assume this will keep you from drifting off to Lisp land? :)

(http://www.notebookreview.com/assets/4612.jpg)

Our next challenge. ;D

Title: Re: Gauche Scheme
Post by: RobbeK on January 30, 2015, 05:24:42 AM

:)

(Lisp took my breath and syntax away ... )

In the mean time (newLisp comes without complex numbers and fractions) , I made a lib for doing this -- compiled it for Linux32 for the moment, but can compile into a DLL.
.. it uses the structure complex ::: double , double .. (it's based on the one from FreePascal/Lazarus)

if someone can use this to extend her/his code , just ask (it's around 130 Kb) -- it even does logGamma (complex)
An example made with these a Mandelcrab based on Z^2.28 + C -- graphics not optimized

best Rob

also attached the Gauche source (not exactly a fair compare , bigger window - around 1.6x (surface wise))

.

Title: Re: Gauche Scheme
Post by: JRS on January 30, 2015, 09:14:08 AM

I think I like to original better.

.

Title: Re: Gauche Scheme
Post by: RobbeK on January 30, 2015, 01:41:12 PM

Hi,

c-wrapper is working fine : (wrote a little lib - doing the mean of two doubles )

gosh> (use c-wrapper)
#<undef>
gosh> (c-load-library "libmean.so.1.0.1")
#<undef>
gosh> (c-include "mean.h")
#<undef>
gosh> (mean 9.7 8.8)
9.25
gosh> (mean 9 8)
8.5

a lot of Scheme here : http://community.schemewiki.org/?scheme-faq-standards

best, Rob

Title: Re: Gauche Scheme
Post by: JRS on January 30, 2015, 02:15:13 PM

An interpreter is useless without a C interface. I'm glad c-wrapper worked out for you.

This reminds me of CERN ROOT in a twisted way.

Title: Re: Gauche Scheme
Post by: RobbeK on January 31, 2015, 12:32:02 PM

Hi John,

Yes, but i'm not very familiar with C -- When young it was still B ::) -- and in Europe, Pascal was favored and educated.
Infact this may be better called a CFFI ; newLISP and Racket Scheme have more universal tools, and accept libs made with FreePascal etc ...

Racket Scheme seems to be in use with Boeing USAF , and while not a compiler - I think it is a very advanced tool with lots of interesting packages. Maybe I'll switch into this one - runs under Win , Linux , MacOS

FFI works in a simple way : from the screen Lib I made :

(require ffi/unsafe ffi/unsafe/define)

(define-ffi-definer mylib-define (ffi-lib "/usr/lib/libscreen2"))
(mylib-define PIXEL (_fun _int _int _int _int _int -> _void ))
(mylib-define ENDSCREEN(_fun -> _void))
(mylib-define SETSCREEN (_fun _int _int _int _int -> _ulong ))
(mylib-define SCRCLR (_fun -> _void))
(mylib-define SCRLOCK (_fun -> _void))
(mylib-define SCRUNLOCK (_fun -> _void))
(mylib-define SCR (_fun _int -> _void))
(mylib-define SCRSLEEP (_fun -> _void))
(mylib-define JULIA (_fun _double _double _double _double _int -> (_list-struct _int _double)))

compiles to executables and distributions - attached (not the fastest graphics, if wanted i can directly poke into the frame's back buffer)

best Rob
c also http://www.pawfal.org/fluxus/

.

Title: Re: Gauche Scheme
Post by: JRS on January 31, 2015, 12:45:14 PM

Like it!

Now that you're on Linux, you have many more options to chose from without breaking the bank.

Title: Re: Gauche Scheme
Post by: RobbeK on February 01, 2015, 07:42:31 AM

Yep, little Rob @ the candy store -- ::)

The code compiled for windows attached -- A distribution that should run without Racket being installed (tested on Wine and on an alien computer running win7 32bit )

Did not test the previous Linux distribution if working with Racket Scheme not installed -- looking for a way keeping the shared lib inside the package without having to install it into /usr/..

Code uses direct poking into the back buffer , and has a little animation.

best, Rob

.

Title: Re: Gauche Scheme
Post by: JRS on February 01, 2015, 11:03:46 AM

Quote

looking for a way keeping the shared lib inside the package without having to install it into /usr/..

Putting the .so library in the same directory as your executable should work as it is part of the search path. You can also use UPX to create a single file bundle to share.

Ran fine under Wine.

Note: Attached image name indicates this is a Gauche rendering when it's not. Sorry!

.

Title: Re: Gauche Scheme
Post by: Mike Lobanovsky on February 01, 2015, 11:41:47 AM

Thanks Rob,

Looks good and works for me though somewhat slow; the animation runs at some 0.5 seconds per frame only.

Title: Re: Gauche Scheme
Post by: RobbeK on February 01, 2015, 12:59:39 PM

Thanks , John , Mike

Yes rather slow , probably this is the "slow downer" (still in Racket bytecode )

(define (poke x y r g b)
(let ((pos (* 4 (+ x (* 500 y)))))
(ptr-set! ptr _byte pos b)
(ptr-set! ptr _byte (+ pos 1) g)
(ptr-set! ptr _byte (+ pos 2) r)))

ptr is the position of the back buffer , but for one frame this has to be ran 250000 times -- much better will be to include it into the main calculation routine and increasing the address by 4bytes every cycle (p += 4 in basic) , here pos is just an offset to the base address ptr. There may be a problem (due to the modern OOP way of thinking -- ptr is an object , not a number (it is a cpointer) ) , i still have to use the pointer and the offset separated , while it is in fact just a number. Very often objects do the opposite of their (raison d'être) reason of existence , they make coding difficult and result slow execution time -- Racket Scheme goes that far that even a color is an object (make-object color% etc ... ) and then you need methods getting a color / rgb channel of a color etc ...

(define gray (send the-color-database find-color "gray")) :'(

"O TEMPORA O MORES" ;)

best , Rob

(i'll replace this uselessness by adding in my FreePascal generated LIB -- poke (scrptr + pos , ubyte) -- simple as that, no need to make things more complicated than they are )

(when (agree?)
( defmacro I() 'we ))

Title: Re: Gauche Scheme
Post by: JRS on February 01, 2015, 10:32:16 PM

Rob,

Would it be difficult to create a rose using the Julia direction your using currently?

While you're thinking about it, here is another Julia Rose.

(http://static.mediabang.org/people-photos/big/110/110047/12c45c1d74f2d8a190eeed9518efe456.jpg)

John

Title: Re: Gauche Scheme
Post by: Mike Lobanovsky on February 02, 2015, 05:38:37 AM

Will this one do? :)

(http://i1240.photobucket.com/albums/gg490/FbslGeek/OGL_Rose_1.png)

It's an OpenGL sample script from a regular FBSL installation. It's purely procedural, i.e. there is no 3D model behind it; everything in it is calculated in real time.

Title: Re: Gauche Scheme
Post by: JRS on February 02, 2015, 10:25:50 AM

I can almost smell it and no thorns which was surprising. ;D

Thanks Mike.

Title: Re: Gauche Scheme
Post by: RobbeK on February 02, 2015, 03:49:31 PM

Hi John,

A Rose with Julia -- I'm afraid not , the problem is that Julia generates an infinite number of attractors (except C=(0,0) and then it only will generate (boring) concentric circles) -- but a rose within a rose ... within a rose ... etc , yes.
But , I can work something out ( i need a few days for it -- only a few years ago they could make some code generating a (more or less realistic) snow flake ..

there are more than enough tries around :
http://th04.deviantart.net/fs70/PRE/f/2011/122/1/f/fractal_rose_by_thorbet-d3fetl3.png

but these are not petal shapes (but of course beautiful)

let's try

Rob

Title: Re: Gauche Scheme
Post by: JRS on February 02, 2015, 03:58:34 PM

WOW!

I'm already happy with that. If you can improve on that rose, I'm sitting on the edge of my chair. :)

Title: Re: Gauche Scheme
Post by: RobbeK on February 05, 2015, 07:58:46 AM

Well, I started with the basics ..

found a formula that generates something flower like , it's based on the cardiode , but i changed the parameter that does the cycles ( 6 i.o. 2)
This is just a shape, the gradients , distortions , rotations , scaling etc come later.

but, but - written in Racket Scheme - i'm very surprised how slow this language is (you will notice when running the code (Win32 or Wine) )
The whole concept of Racket imho is very academic

: colors are objects
: for gaining some speed I work on a bitmap -- to be able to transfer the bitmap to the canvas you have to set up a callback which is triggered by on-paint
: the pixel setting on the bmp is also slow -- this should give hope there is some boundery checking,but there is none

(any good scripting language should outperform this ... )

: the processor activity during editing , coding , running any scheme source is upto the limit any time.

maybe not the good start for a rose -- more a papaver/poppy -- but in my langauge it is called " klaproos or kollenbloem " (kol = heks = old english hex i think ... so a hexflower

patience is needed when running attached code (wine or win32) -- it's nothing yet , just the geometry

best Rob

.

Title: Re: Gauche Scheme
Post by: JRS on February 05, 2015, 10:59:33 AM

Looks like a great start Rob! Please keep us updated as this unfolds.

Title: Re: Gauche Scheme
Post by: Mike Lobanovsky on February 06, 2015, 12:41:56 AM

Awesome indeed! Can't wait to see the final shape. :)

Title: Re: Gauche Scheme
Post by: RobbeK on February 06, 2015, 02:42:03 AM

Thanks ;)

In glorious 3D now - mixed it with a paraboloid (Z value) -- compiled with GFA under Wine (the nice thing is , here the hlp files do work)

More later - the number of petals can be changed now (not included in the interface) -- compositions next (spirals , concentric etc ...)

best Rob
(will convert to Gauche as a test - already around 110.000 points calculated)

added : the exec. 9 petals (somewhat nicer) -- runs from the flower3D.exe locations

addendum : the Gauche Scheme script -- amazingly fast speed (measured on setting up the GL_COMPILE list ) -- easy interface :
use the mouse to start / stop rotation (left/right) -- (display (number->string pi)) may be removed from the script (just checking the value)
identical script runs on Win32 / Wine / Linux
-------------------------------
(use gl)
(use gl.glut)

(define pi (* 2.0 (acos 0)))

(display (number->string pi))

(define (Fflower a t nr)
(let ((x (* a (- (* nr (cos t)) (cos (* nr t)))))
(y (* a (- (* nr (sin t)) (sin (* nr t)))))
(z (* a a 0.5) ))
(list x y z)))

(define *spin* 0.0)
(define *title* "Left mouse to start rotation - Right to stop")

(define (init)
(gl-clear-color 0.0 0.0 0.0 0.0)
(gl-shade-model GL_FLAT)
)

(define (make-list)
(gl-new-list 1 GL_COMPILE)
(gl-begin GL_POINTS)

(do ((a 0.2 (+ a 0.06)))
((> a 5.0))
(do ((t 0.0 (+ t (/ pi 500))))
((> t (* 2 pi)))
(let ((res (Fflower a t 8.0)) (color (/ a 5.0)) )
(gl-color color (- 1 color) 0.0)
(gl-vertex (car res) (cadr res) (caddr res) ))))
(gl-end)
(gl-end-list))

(define (disp)
(gl-clear GL_COLOR_BUFFER_BIT)
(gl-push-matrix)

(gl-rotate *spin* 1.0 1.0 1.0)
(gl-call-list 1)
(gl-pop-matrix)
(glut-swap-buffers)
)

(define (spin-display)
(set! *spin* (modulo (+ *spin* 2.0) 360.0))
(glut-post-redisplay)
)

(define (reshape w h)
(gl-viewport 0 0 w h)
(gl-matrix-mode GL_PROJECTION)
(gl-load-identity)
(gl-ortho -50.0 50.0 -50.0 50.0 -100.0 100.0)
(gl-matrix-mode GL_MODELVIEW)
(gl-load-identity)
)

(define (mouse button state x y)
(cond
((= button GLUT_LEFT_BUTTON)
(when (= state GLUT_DOWN) (glut-idle-func spin-display)))
((= button GLUT_RIGHT_BUTTON)
(when (= state GLUT_DOWN) (glut-idle-func #f))))
)

(define (keyboard key x y)
(cond
((= key 27) (exit 0))
))

(define (main args)
(glut-init args)
(glut-init-display-mode (logior GLUT_DOUBLE GLUT_RGB))
(glut-init-window-size 500 500)
(glut-init-window-position 100 100)
(glut-create-window *title*)
(init)
(glut-display-func disp)
(glut-reshape-func reshape)
(glut-keyboard-func keyboard)
(glut-mouse-func mouse)
(make-list)
(glut-main-loop)
0)
---------------------------------------------------------------------

.

Title: Re: Gauche Scheme
Post by: JRS on February 06, 2015, 11:19:42 AM

I see this trending to an animated bloom. 8)

Title: Re: Gauche Scheme
Post by: RobbeK on February 07, 2015, 05:41:15 AM

possibly it may become a late bloomer 8)

What's your opinion about the tk interface , John -- something worthy -- it only needs one scm source into the lib directory , very easy (tk/tcl should be present on most UNIX distributions)

attached the scm script , changed to solids now (quads) -- everything ready to produce some more complex (even fractal) constructions.
Possibly input interfacing with the ogl windows is too devious ?? (some buttons, textfields could be set up -- in the examples there's something with bitmap font char's that can be used )

best Rob

already made something worth looking at : compoFlower.scm (imho a good start for some serious work)

.

Oxygen Basic

Information => Open Forum => Topic started by: JRS on January 17, 2015, 12:17:40 AM