; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xmtest.scm,v 1.2 1992/07/03 14:04:35 campbell Beta $
;
; Random test functions to exercise Motif and Xt interface
;
(require 'stdio)
(require (in-vicinity (library-vicinity) "x11.scm"))
(require (in-vicinity (library-vicinity) "xt.scm"))
(require (in-vicinity (library-vicinity) "xm.scm"))
(require (in-vicinity (library-vicinity) "xevent.scm"))
(require (in-vicinity (library-vicinity) "xmsubs.scm"))

(define (say x) (display x) (newline) (force-output))

(define (go)
  (xt:realize-widget top-level)
  (xt:main-loop))

(define top-level
  (if (defined? vs:top-level)
      (xt:app-create-shell "shell" "Shell"
			   xt:application-shell
			   (xt:display vs:top-level))
      (xt:initialize "shell" "Shell")))

(xt:set-values top-level xm:n-allow-shell-resize #t)


(define (stringlist->xmstringvector sl)
  (let* ((sv (list->vector sl))
	 (len (vector-length sv)))
    (do ((i 0 (1+ i)))
	((= i len) sv)
      (vector-set! sv i (xm:string-create (vector-ref sv i))))))

(define listvector
  (stringlist->xmstringvector
   '(
     "thing one"
     "thing two"
     "and another thing"
     "this is a longer item"
     "this is another longer item"
     "I need to have lots of items"
     "in my list"
     "so I can test out the scrolling"
     "functions"
     )))

(define (list-demo)
  (make-list top-level))

(define (make-list parent)
  (let ((w
	 (xt:create-managed-widget
	  "list"
	  xm:list
	  parent
	  xm:n-height 200
	  xm:n-items (xm:vector->xmstringtable listvector)
	  xm:n-item-count (vector-length listvector)
	  xm:n-selection-policy xm:multiple-select)))
    (xt:add-callback
     w xm:n-multiple-selection-callback
     (lambda (w)
       (let* ((n (xt:get-value w xm:n-selected-item-count xt:integer))
	      (items (xt:get-value w xm:n-selected-items xt:xmstringtable n))
	      (itemvector (xm:xmstringtable->vector items)))
	 (printf "There are %d selected items\\n" n)
	 (do ((i 0 (1+ i)))
	     ((= i n) #t)
	   (let ((s (xm:string-get-first-segment (vector-ref itemvector i))))
	     (printf "Item %d is \"%s\"\\n" i s)
	     (force-output))))))
    w))

(define (scroll-demo)
  (let* ((sw
	  (xt:create-managed-widget
	   "slist"
	   xm:scrolled-window
	   top-level
	   xm:n-height 400
	   xm:n-width 300
	   xm:n-scrolling-policy xm:automatic))
	 (ww
	  (make-list sw)))
    (xt:set-values
     sw
     xm:n-work-window ww)))

(define (menu-demo)
  (let* ((bb (xt:create-managed-widget
	      "bboard" xm:bulletin-board top-level
	      xt:n-width 200
	      xt:n-height 200))
	 (menu (make-popup-menu
		"Press here, honey"
		bb
		`("Button 1" ,(lambda (w) (say "Button 1")))
		`("Button 2" ,(lambda (w) (say "Button 2")))
		`("Button 3" ,(lambda (w) (say "Button 3"))) )))
    (xt:add-event-handler
     bb
     x:button-press-mask
     0
     (lambda (widget event)
       (xm:menu-position menu event)
       (xt:manage-children menu)))
    menu))

(define (event-demo)
  (let* ((pw (xt:create-managed-widget
	      "pane" xm:paned-window top-level))
	 (rc (xt:create-managed-widget
	      "rc" xm:row-column pw))
	 (da (xt:create-managed-widget
	      "da" xm:drawing-area pw
	      xm:n-width  200
	      xm:n-height 200))
	 (mt (xt:create-managed-widget
	      "mt" xm:label rc)))
    (xt:add-event-handler
     da x:leave-window-mask 0
     (lambda args
       (display "leave window: ")
       (display args)
       (newline)))
    (xt:add-event-handler
     da x:pointer-motion-mask 0
     (lambda (w e)
       (let ((x (x:get-event-field e x:motion-event:x))
	     (y (x:get-event-field e x:motion-event:y)))
	 (xm:wprintf mt "x: %d y: %d" x y))))))

(define (xm:wprintf w f . args)
  (let* ((buf (make-string 80 #\space))
	 (l (apply sprintf buf (cons f args)))
	 (s (substring buf 0 l))
	 (label (xm:string-create s)))
    (xt:set-values w xm:n-label-string label)))

; (menu-bar name parent ("label1" menu1)

(define (menu-bar name parent)
  (let ((menubar (xt:create-managed-widget
		  name xm:row-column parent
		  xm:n-row-column-type xm:menu-bar)))
	(make-pulldown-menu
	 "Folder" menubar
	 `("Open" ,(lambda (w) (say "Open")))
	 `("Create"  ,(lambda (w) (say "Create")))
	 `("Browse" ,(lambda (w) (say "Browse"))))
	(make-pulldown-menu
	 "View" menubar
	 `("Open" ,(lambda (w) (say "Open")))
	 `("Create"  ,(lambda (w) (say "Create")))
	 `("Browse" ,(lambda (w) (say "Browse"))))
	(make-pulldown-menu
	 "Help" menubar
	 `("About" ,(lambda (w) (say "Open")))
	 `("Help"  ,(lambda (w) (say "Create"))))
	menubar))


(define (menubar-demo)
  (let ((bb (xt:create-managed-widget
	     "bboard" xm:bulletin-board top-level
	     xm:n-margin-height 0
	     xm:n-margin-width 0)))
    (menu-bar "menubar" bb)))

(define drawing-area 0)

(define (draw-demo)
  (let* ((da (xt:create-managed-widget
	      "drawing-area" xm:drawing-area top-level
	      xt:n-height 200 xt:n-width 200))
	 (disp (xt:display da))
	 (window (begin (xt:realize-widget top-level) (xt:window da)))
	 (xgc1 (x:create-gc disp () x:gc-foreground 0 x:gc-background 1))
	 (xgc2 (x:create-gc disp () x:gc-foreground 1 x:gc-background 0)))
    (xt:add-event-handler
     da x:exposure-mask 0
     (lambda (w e)
       (let ((x (xt:get-value w xt:n-width xt:integer))
	     (y (xt:get-value w xt:n-height xt:integer)))
	 (x:fill-rectangle disp window xgc1 0 0 x y)
	 (x:draw-points disp window xgc2 0
			'(10 . 10)
			'(11 . 11)
			'(12 . 12)
			'(13 . 13)
			'(14 . 14)
			'(15 . 14)
			'(16 . 14)
			'(17 . 14)
			'(18 . 14)
			'(19 . 14)
			'(20 . 14))
	 )))
    (xt:add-callback
     da xm:n-resize-callback
     (lambda (w)
       (let ((x (xt:get-value w xt:n-width xt:integer))
	     (y (xt:get-value w xt:n-height xt:integer)))
	 (printf "width=%d, height=%d\\n" x y)
       )))
    (x:clear-area disp window 0 0 0 0 #t)
    (set! drawing-area da)
    (x:flush (xt:display da))
    ))

