;;; This module provides a rudimentary emulation of the Elk
;;; Motif environment, permitting some Elk applications to run
;;; under xmscm unchanged.

;; Initialization

(load "x11")
(load "xm")

(define (load-widgets . args) #t)	; they're all pre-loaded

(define (application-initialize sym)
  (let ((name (symbol->string sym)))
    (if (defined? vs:top-level)
	(xt:app-create-shell name name xt:application-shell
			     (xt:display vs:top-level))
	(xt:initialize name name))))

(define (create-managed-widget class parent)
  (xt:create-managed-widget (xt:class-name class) class parent))

(define realize-widget xt:realize-widget)

(define (context-main-loop con)
  (if (not (defined? vs:top-level))
      (xt:main-loop)))

(define (context-add-timeout con when func)
  (xt:add-time-out when func))

(define (remove-timeout t)
  (xt:remove-time-out t))

(define (find-class class-name)
  (case class-name
    ((bulletin-board) xm:bulletin-board)
    ((cascade-button) xm:cascade-button)
    ((drawing-area) xm:drawing-area)
    ((push-button) xm:push-button)
    ((row-column) xm:row-column)
    ((scroll-bar) xm:scroll-bar)
    (else (error "invalid class name" class-name))))

(define (set-values! . argl)
  (let ((widget (car argl)))
    (let loop ((args (cdr argl)))
      (let ((sym (car args))
	    (name (elkid->scmid (car args)))
	    (value (cadr args)))
	(if (equal? value 'empty)
	    (set! value (make-string 0)))
	(if (equal? sym 'label-string)
	    (begin
	      (if (symbol? value)
		  (set! value (symbol->string value)))
	      (set! value (xm:string-create value))))
	(if (equal? sym 'alignment)
	    (set! value
		  (cond
		   ((string=? value "alignment_beginning")
		    xm:alignment-beginning)
		   ((string=? value "alignment_center")
		    xm:alignment-center)
		   ((string=? value "alignment_end")
		    xm:alignment-end))))
	(if (equal? sym 'orientation)
	    (set! value
		  (case value
		    ((horizontal) xm:horizontal)
		    ((vertical) xm:vertical))))
	(format #t "~s: ~s~%" name
		(if (xm:xmstring? value)
		    (xm:string-get-first-segment value)
		    value))
	(case sym
	  ((activate-callback arm-callback disarm-callback)
	   (xt:add-callback widget name (car value)))
	  (else	(xt:set-values widget name value)))
	(set! args (cddr args))
	(if (not (null? args))
	    (loop args))))))

(define (elkid->scmid sym)
  (let ((pair
	 (assoc
	  sym
	  `(
	    (activate-callback	. ,xm:n-activate-callback)
	    (alignment		. ,xm:n-alignment)
	    (arm-callback	. ,xm:n-arm-callback)
	    (border-width	. ,xm:n-border-width)
	    (disarm-callback	. ,xm:n-disarm-callback)
	    (height		. ,xm:n-height)
	    (label-string	. ,xm:n-label-string)
	    (menu-bar		. ,xm:n-menu-bar)
	    (menu-help-widget	. ,xm:n-menu-help-widget)
	    (orientation	. ,xm:n-orientation)
	    (recompute-size	. ,xm:n-recompute-size)
	    (show-separator	. ,xm:n-show-separator)
	    (width		. ,xm:n-width)
	    (x			. ,xm:n-x)
	    (y			. ,xm:n-y)
	    ))))
    (if (not pair)
	(error "unmapped elk resource symbol" sym)
	(cdr pair))))
	 
(define (add-callback widget sym func)
  (if func
      (xt:add-callback widget (elkid->scmid sym) func)))
