> I have also been doing some bindings for Scheme (TinyScheme), and been
> meaning to release them for a while, but always something will crop up
> (always another feature to add or another bug to fix).
>
> Originally I was doing it all in the C files an registered all the
> relevant functions using FFI. Recently I have been rewriting it in
> (mostly) pure Scheme.
>
> I would much rather add to pre-existing Scheme bindings however. Have
> you got any code worth releasing Matt?
>
> Timothy Downs
> [EMAIL PROTECTED]
Its definitely not release quality material but I'm so dang busy that here it
is anyway...
My stuff is pure Scheme also, written for scm with slib. I have scm + parts
of slib running nicely on the VTech Helio. I suspect that I'm no further
along than you but for grins I will attach a file with my latest (not touched
in weeks) code. The calculator app is torn apart and not functional but if
you run it it should draw the calculator on screen. Also attached is a reply
to a post I made to comp.lang.scheme regarding performance issues with my
aproach.
I would love to see bindings for scheme developed that made it fairly easy to
switch between various scheme implementations. Also we can keep hoping for a
root-less pgserver which if it ever came to pass would give any scheme
implementations with picogui bindings X graphics.
I am expecting a break here in a couple of weeks where I hope to update my
Helio build system and do some more work on pgui.scm. It would be great if we
could converge on a set of bindings.
Matt
--
> ----------------
> Powered by telstra.com
;;<scanline> kiatoa: I just added the PG_WP_SPACING property to pgserver
;;<scanline> kiatoa: set the button's PG_WP_SPACING to 0, and on the boxes they're in
set PG_WP_TRANSPARENT to 1 and PG_WP_MARGIN to 0
(require 'socket)
(require 'i/o-extensions)
(require 'byte)
(require 'logical)
;; (require 'printf)
(define $pgport (make-stream-socket af_inet))
;; (set! $pgport (socket:connect $pgport (inet:string->address "localhost") 30450))
(define $tot-errors 0)
(define $max-tot-errors 500)
(define $retrys 0)
(define $max-retrys 20)
;;(define (pgfraction n d)
;; (
;; receive an unsigned 32 bit integer
(define (get-pg-u32)
(+ (* 16777216 (read-byte $pgport))
(* 65536 (read-byte $pgport))
(* 256 (read-byte $pgport))
(read-byte $pgport)))
;; receive an unsigned 16 bit integer
(define (pg-get-u16)
(+ (* 256 (read-byte $pgport)) (read-byte $pgport)))
;; receive an unsigned 8 bit integer
(define (get-pg-u8)
(read-byte $pgport))
;; send an unsigned 32 bit integer
(define (pg-send-u32 $data)
(let (($m1 (bit-field $data 24 33))
($m2 (bit-field $data 16 24))
($m3 (bit-field $data 8 16))
($m4 (bit-field $data 0 8)))
(display (integer->char $m1) $pgport)
(display (integer->char $m2) $pgport)
(display (integer->char $m3) $pgport)
(display (integer->char $m4) $pgport)))
;; send an unsigned 16 bit integer
(define (pg-send-u16 $data)
;; (printf "Sending u16 %-02s.\n" (number->string $data 16))
(display (integer->char (bit-field $data 8 15)) $pgport)
(display (integer->char (bit-field $data 0 7)) $pgport))
;; send an unsigned 8 bit integer
(define (pg-send-u8 $data)
;; (printf "Sending u8 %-0s.\n" (number->string $data 16))
(display (integer->char (bit-field $data 0 7)) $pgport))
;; expect to get back: (826366246 12 ?)
(define (get-pg-hello)
(list (get-pg-u32)
(pg-get-u16)
(pg-get-u16)))
(define (mk-id)
(let (($curr-id 0))
(lambda ()
(set! $curr-id (+ $curr-id 1))
$curr-id)))
(define newid (mk-id))
(define (pgui-constants $name)
(case $name
((SZMODE_CNTFRACT ) 32768)
(else #f)))
(define (pgui-request-type $type)
(case $type
((PING ) 0 ) ;; Simply return if server is ok
((UPDATE ) 1 ) ;; Call update()
((MKWIDGET ) 2 ) ;; Make a widget, return handle
((MKBITMAP ) 3 ) ;; Make a bitmap, return handle
((MKFONT ) 4 ) ;; Make a fontdesc, return handle
((MKSTRING ) 5 ) ;; Make a string, return handle
((FREE ) 6 ) ;; Free a handle
((SET ) 7 ) ;; Set a widget param
((GET ) 8 ) ;; Get a widget param, return it
((MKTHEME ) 9 ) ;; Load a compiled theme
((IN_KEY ) 10 ) ;; Dispatch keyboard input
((IN_POINT ) 11 ) ;; Dispatch pointing device input
((WAIT ) 13 ) ;; Wait for an event
((MKFILLSTYLE ) 14 ) ;; Load a fill style, return handle
((REGISTER ) 15 ) ;; Register a new application
((MKPOPUP ) 16 ) ;; Create a popup root widget
((SIZETEXT ) 17 ) ;; Find the size of text
((BATCH ) 18 ) ;; Execute many requests
((REGOWNER ) 19 ) ;; Get exclusive privileges
((UNREGOWNER ) 20 ) ;; Give up exclusive privileges
((SETMODE ) 21 ) ;; Set video mode/depth/rotation
((GETMODE ) 22 ) ;; Return a modeinfo struct
((MKCONTEXT ) 23 ) ;; Enter a new context
((RMCONTEXT ) 24 ) ;; Clean up and kills the context
((FOCUS ) 25 ) ;; Force focus to specified widget
((GETSTRING ) 26 ) ;; Return a RESPONSE_DATA
((DUP ) 27 ) ;; Duplicate an object
((SETPAYLOAD ) 28 ) ;; Set an object's payload
((GETPAYLOAD ) 29 ) ;; Get an object's payload
((CHCONTEXT ) 30 ) ;; Change a handle's context
((WRITETO ) 31 ) ;; Stream data to a widget
((UPDATEPART ) 32 ) ;; Update subtree defined by wgt
((MKARRAY ) 33 ) ;; Make a array, return handle
((RENDER ) 34 ) ;; Render gropnode(s) to a bitmap
((NEWBITMAP ) 35 ) ;; Create a blank bitmap
((THLOOKUP ) 36 ) ;; Perform a theme lookup
((GETINACTIVE ) 37 ) ;; Get milliseconds of inactivity
((SETINACTIVE ) 38 ) ;; Set milliseconds of inactivity
((DRIVERMSG ) 39 ) ;; Send a message to all drivers
((LOADDRIVER ) 40 ) ;; Load input/misc (not video)
((GETFSTYLE ) 41 ) ;; Get info on a font style
((FINDWIDGET ) 42 ) ;; Get widget handle by name
((CHECKEVENT ) 43 ) ;; Return number of queued events
((SIZEBITMAP ) 44 ) ;; Find the size of a bitmap
((APPMSG ) 45 ) ;; Send PG_WE_APPMSG to any widget
((CREATEWIDGET) 46 ) ;; Create widget
((ATTACHWIDGET) 47 ) ;; Attach widget
((FINDTHOBJ ) 48 ) ;; Find theme object by name
((TRAVERSEWGT ) 49 ) ;; Find widgets after this one
(else #f)))
(define (pgui-widget-type $type)
(case $type
((TOOLBAR ) 0 ) ;; �
((LABEL ) 1 ) ;; �
((SCROLL ) 2 ) ;; �
((INDICATOR ) 3 ) ;; �
((BITMAP ) 4 ) ;; �
((BUTTON ) 5 ) ;; �
((PANEL ) 6 ) ;; Can't be used to create a new widget with PGREQ_MKWIDGET
but can
;; be returned after a PGREQ_REGISTERAPP
((POPUP ) 7 ) ;; Can't be used to create a new widget with PGREQ_MKWIDGET,
use
;; PGREQ_MKPOPUP instead.
((BOX ) 8 ) ;; �
((FIELD ) 9 ) ;; �
((BACKGROUND ) 10) ;; pgserver internal use only!
((MENUITEM ) 11) ;; A variation on button
((TERMINAL ) 12) ;; A full terminal emulator
((CANVAS ) 13) ;; �
((CHECKBOX ) 14) ;; Another variation of button
((FLATBUTTON ) 15) ;; Yet another customized button
((LISTITEM ) 16) ;; Still yet another...
((SUBMENUITEM) 17) ;; Menuitem with a submenu arrow
((RADIOBUTTON) 18) ;; Like a check box, but exclusive
((TEXTBOX ) 19) ;; Client-side text layout
((PANELBAR ) 20) ;; Draggable bar and container
(else #f)))
(define (pgui-derive-type $type)
(case $type
((AFTER) 1)
((INSIDE) 2)
((BEFORE) 3)
(else #f)))
(define (pgui-widget-prop $type)
(case $type
((SIZE) 1)
((SIDE) 2)
((ALIGN) 3)
((BGCOLOR) 4)
((COLOR) 5)
((SIZEMODE) 6)
((TEXT) 7)
((FONT) 8)
((VALUE) 14)
((TRANSPARENT) 9)
(else #f)))
(define (get-pg-response)
(let (($type (pg-get-u16))
($errt (pg-get-u16)))
(cond
((eq? $type 1) ;; PG_ERROR
(let (($msglen (pg-get-u16))
($dummy (pg-get-u16))
($id (get-pg-u32)))
(if (> $msglen 0)
(let loop (($pos 1)
(@result '()))
(if (< $pos $msglen)
(loop (+ $pos 1) (append @result (list (read-char $pgport))))
(begin
(read-char $pgport) ;; discard the ^@ ???
(display (list->string @result ))
(exit)))))))
((eq? $type 3)
;; (display "got an event")
(let (($event $errt)
($from (get-pg-u32))
($param (get-pg-u32)))
$from))
((eq? $type 2)
(let (($id (get-pg-u32))
($data (get-pg-u32)))
(list $id $data)))
((eq? $type 4) ;; this should be a string
(let (($id (get-pg-u32))
($msglen (get-pg-u32)))
(if (> $msglen 0)
(let loop (($pos 1)
(@result '()))
(if (< $pos $msglen)
(loop (+ $pos 1) (append @result (list (read-char $pgport))))
(begin
(read-char $pgport) ;; purge the null
(list->string @result)))))))
;; (list (read-char $pgport)))))))))
(else (display "Unknown response type ")
(display $type)))))
(define (pg-send-chars @list) ;; send a list of characters to the port
(let loop (($head (car @list))
(@tail (cdr @list)))
(if (not (null? @tail))
(begin
(display $head $pgport)
(loop (car @tail) (cdr @tail)))
(begin
(display $head $pgport)))))
(define (pg-mk-string $string)
(let (($l (+ (string-length $string) 1)) ;; add one for nul
(@sl (append (string->list $string) (list #\nul)))) ;; add nul
(pg-request $l 'mkstring)
(pg-send-chars @sl))
(get-pg-response))
(define (pg-get-string $string)
(pg-request 4 'getstring)
(pg-send-u32 (get-handle $string))
(get-pg-response))
(define (pg-mk-app $string)
(let (($s (pg-mk-string $string)))
(pg-request 8 'register)
(pg-send-u32 (get-handle $s))
(pg-send-u16 1) ;; app-normal
(pg-send-u16 0)
(get-pg-response)))
(define (pg-mk-widget $wtype $rship $parent)
(pg-request 8 'mkwidget)
;; now the pgreqd_mkwidget
(pg-send-u16 (pgui-derive-type $rship))
(pg-send-u16 (pgui-widget-type $wtype)) ;; app-normal
(pg-send-u32 (get-handle $parent))
(get-pg-response))
(define (pg-request $l $type)
(pg-send-u32 (newid))
(pg-send-u32 $l)
(pg-send-u16 (pgui-request-type $type))
(pg-send-u16 0))
(define (pg-set-property $widget $property $value)
(pg-request 12 'set)
;; now the new propreties
(pg-send-u32 (get-handle $widget))
(pg-send-u32 $value)
(pg-send-u16 (pgui-widget-prop $property))
(pg-send-u16 0)
(get-pg-response))
(define (pg-get-property $widget $property)
(pg-request 8 'get)
;; what to get
(pg-send-u32 (get-handle $widget))
(pg-send-u16 (pgui-widget-prop $property))
(pg-send-u16 0)
(get-pg-response))
(define (pg-wait)
(pg-request 0 'wait)
(get-pg-response))
(define (pg-destroy $h)
(pg-request 4 'free)
(pg-send-u32 (get-handle $h))
(get-pg-response))
(define (pg-ping)
(pg-request 0 'ping)
(let ((@result (get-pg-response)))
(if (not (list? @result)) (pg-ping)
@result)))
(define (pg-update)
(pg-request 0 'update)
(get-pg-response))
(define (get-id @id)
(car @id))
(define (get-handle @id)
(cadr @id))
(define @ds '(("example" #f))) ;; The central data structure
(define (add-obj $name $obj)
(let (($fobj (assoc $name @ds)))
(if $fobj
(replace-obj $name $obj)
(set! @ds (cons (list $name $obj) @ds)))))
;; replaces obj if found else does nothing
(define (replace-obj $name $obj)
(let loop ((@head (car @ds))
(@tail (cdr @ds))
(@result '()))
;; if we are at the end of the list return result or result with obj if @head is
obj
(if (null? @tail)
(if (equal? $name (car @head))
(set! @ds (cons (list $name $obj) @result))
(set! @ds @result))
(let (($n (car @head)))
(loop (car @tail)
(cdr @tail)
(if (equal? $name $n) ;; remember this. do the "if" on @result to
compress the code
(cons (list $name $obj) @result)
(cons @head @result)))))))
(define (get-obj $name)
(let (($obj (assoc $name @ds)))
(if $obj (cadr $obj) #f)))
;; demo app - calculator
(define @keys '())
(define @buttons (reverse
'(("sin" "cos" "tan" "" "drop")
("1/x" "" "" "x^y" "del")
("" "" "" "swap" "/")
("" "7" "8" "9" "x")
("" "4" "5" "6" "-")
("" "1" "2" "3" "+")
("" "0" "." "" "enter"))))
(define @operators (list (list "+" +) (list "-" -) (list "x" *) (list "/" /)
(list "x^y" expt) (list "sin" sin) (list "cos" cos)
(list "tan" tan)))
(define (mkbuttons $f2 @buttons)
(let looprow ((@row (car @buttons))
(@rtail (cdr @buttons))
($f (pg-mk-widget 'box 'inside $f2)))
;; (printf "Created box %d.\n" (get-handle $f))
(mkbuttonrow $f @row)
;; (pg-update)
(if (not (null? @rtail))
(looprow (car @rtail) (cdr @rtail) (pg-mk-widget 'box 'inside $f2)))))
(define (mkbuttonrow $f @row)
(let loopcol (($item (car (reverse @row)))
(@ctail (cdr (reverse @row)))
($b (pg-mk-widget 'button 'inside $f)))
(let (($s (pg-mk-string $item)))
(pg-set-property $b 'text (get-handle $s))
(pg-set-property $b 'size 261) ;; 261 == h0105 01/05 ratio
(pg-set-property $b 'sizemode (pgui-constants 'SZMODE_CNTFRACT))
(set! @keys (cons (list (get-handle $b) $item (string->symbol $item)) @keys))
$s)
(if (not (null? @ctail))
(loopcol (car @ctail) (cdr @ctail) (pg-mk-widget 'button 'inside $f)))))
(define (calc)
(if (port-type $pgport) (close-port $pgport))
(let (($port (make-stream-socket af_inet)))
(set! $pgport (socket:connect $port 2130706433 ;;(inet:string->address
"localhost")
30450))
(if (not (eq? (car (get-pg-hello)) 826366246)) (display "Version mismatch!\n"))
(let* (($tl (pg-mk-app "Calc"))
($f1 (pg-mk-widget 'box 'inside $tl))
($l1 (pg-mk-widget 'label 'inside $f1))
($l2 (pg-mk-widget 'label 'inside $f1))
($l3 (pg-mk-widget 'label 'inside $f1))
($l4 (pg-mk-widget 'label 'inside $f1))
($f2 (pg-mk-widget 'box 'after $f1))
;; calculator variables
)
;; (pg-update)
(add-obj "l1" $l1)
(add-obj "l2" $l2)
(add-obj "l3" $l3)
(add-obj "l4" $l4)
(pg-set-property $l1 'text (get-handle (pg-mk-string "0")))
(pg-set-property $l2 'text (get-handle (pg-mk-string " ")))
(pg-set-property $l3 'text (get-handle (pg-mk-string " ")))
(pg-set-property $l4 'text (get-handle (pg-mk-string " ")))
;; (pg-update)
(set! $tot-errors 0) ;; reset the error counter here
(mkbuttons $f2 @buttons)
(pg-update)
(go))))
;; push the stack up and return an empty string
(define (push-stack)
(let (($l1 (get-obj "l1"))
($l2 (get-obj "l2"))
($l3 (get-obj "l3"))
($l4 (get-obj "l4")))
;;(pg-destroy (pg-get-property $l4 'text))
(pg-set-property $l4 'text (get-handle (pg-get-property $l3 'text)))
(pg-set-property $l3 'text (get-handle (pg-get-property $l2 'text)))
(pg-set-property $l2 'text (get-handle (pg-get-property $l1 'text))))
"") ;; return an empty string
(define (go)
(let (($l1 (get-obj "l1"))
($l2 (get-obj "l2"))
($l3 (get-obj "l3"))
($l4 (get-obj "l4"))
($entry-state 'init)) ;; flag for a new number being entered
(let loop (($key (cadr (assoc (pg-wait) @keys))))
(display $key)
(cond
((member $key (list "1" "2" "3" "4" "5" "6" "7" "8" "9" "0" "."))
(let* (($sh (pg-get-property $l1 'text))
($s (if $new-num (push-stack)
(pg-get-string $sh)))
($ns (remove-leading-zeros
(string-append $s $key))))
(pg-set-property $l1 'text (get-handle (pg-mk-string $ns)))
;;(pg-destroy $sh)
(set! $new-num #f)
(pg-update)))
((equal? $key "enter")
(push-stack)
(set! $new-num #t)
(pg-update))
((member $key (list "+" "-" "/" "x" "x^y"))
(let* (($s1 (pg-get-property $l1 'text))
($s2 (pg-get-property $l2 'text))
($s3 (pg-get-property $l3 'text))
($s4 (pg-get-property $l4 'text))
($n1 (string->number (pg-get-string $s1)))
($n2 (string->number (pg-get-string $s2)))
($result ((cadr (assoc $key @operators)) $n2 $n1)))
;; (printf "Result of %d %s %d is %d\n" $n1 $key $n2 $result)
(pg-set-property $l1 'text
(get-handle (pg-mk-string (number->string $result))))
(pg-set-property $l2 'text (get-handle $s3))
(pg-set-property $l3 'text (get-handle $s4))
(pg-set-property $l4 'text (get-handle (pg-mk-string "")))
(set! $new-num #t)
(pg-update)))
(else (display $key)))
(loop (cadr (assoc (pg-wait) @keys))))))
(define (remove-leading-zeros $s)
(let (($l (string-length $s)))
(if (eq? #\0 (string-ref $s 0))
(remove-leading-zeros
(substring $s 1 $l))
$s)))
(if (not (defined? $pgport))
(define $pgport (make-stream-socket af_inet)))
(define (init)
(set! $pgport (make-stream-socket af_inet))
(set! $pgport
(socket:connect $pgport
;; (inet:string->address "localhost")
2130706433
30450))
(get-pg-hello))
(define (test-label)
(let* (($tl (pg-mk-app "Label"))
($l1 (pg-mk-widget 'label 'inside $tl)))
(pg-set-property $l1 'text (get-handle (pg-mk-string "01")))
(let (($t (pg-get-property $l1 'text)))
;; (display (pg-get-string $t))
(display $t))
(pg-update)))
(define (test-button)
(let* (($tl (pg-mk-app "Button"))
($b1 (pg-mk-widget 'button 'inside $tl)))
(pg-set-property $b1 'text (get-handle (pg-mk-string "Button")))
(let (($t (pg-get-property $b1 'text)))
;; (display (pg-get-string $t))
(display $t))
(pg-update)))
--- Begin Message ---
--- End Message ---
