From 04ba26ee03b0e3c44d8591ae239280e607162fa1 Mon Sep 17 00:00:00 2001 From: nofreude Date: Fri, 15 Feb 2002 14:57:54 +0000 Subject: [PATCH] first implementation of the widget-functions for Scheme48 --- scheme/xt/widget.scm | 389 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 389 insertions(+) create mode 100644 scheme/xt/widget.scm diff --git a/scheme/xt/widget.scm b/scheme/xt/widget.scm new file mode 100644 index 0000000..6fed313 --- /dev/null +++ b/scheme/xt/widget.scm @@ -0,0 +1,389 @@ +;; --- widget functions --- + +(define (help-maybe-symbol->string obj) + (if (symbol? obj) + (symbol->string obj) + (if (string? obj) + obj + (error "no valide operand" help-maybe-symbol->string)))) + + +(define (help-arglist-symbol->string arg-list) + (letrec ((loop + (lambda (new-list old-list) + (if (null? old-list) + ;should be save without (reverse list) + new-list + (loop (cons (help-maybe-symbol->string (car old-list)) + (cons (cdar old-list) + new-list)) + (cddr old-list)))))) + (loop '() arg-list))) + + + +(define (destroy-widget widget) + (if (get-free widget) + (error "widget is already destroyed" destroy-widget) + (%destroy-widget (widget-Xwidget widget)))) + +(import-lambda-definition %destroy-widget (XWidget) + "scxt_Destroy_Widget") + + +(define create-shell + (lambda (app-name app-class parent display . args) + (if (get-free parent) + (error "free widget" create-shell) + (make-widget + (%create-shell (help-maybe-symbol->string app-name) + (help-maybe-symbol->string app-class) + (widget-Xwidget parent) + (display-Xdisplay display) + (help-arglist-symbol->string arg-list)))))) + +(import-lambda-definition %create-shell () + "scxt_Create_Shell") + + + +(define create-widget + (lambda args + (apply int-create-widget #f args))) + +(define create-managed-widget + (lambda args + (apply int-create-widget #t args))) + + +;; abstraction of create-widget(s) create-managed-widget(s)... +(define int-create-widget + (lambda (managed? . args) + (let* ((arg-list-length (length args)) + (arg-list-even? (even? arg-list-length)) + (num-args (if arg-list-even? + (/ (- arg-list-length 2) 2) + (/ (- arg-list-length 1) 2))) + (real-arg-list (if arg-list-even? + (cddr args) + (cdddr args))) + (widget-name (if arg-list-even) + ; this fun has to be implemented... + (%class-name (car args)) + (if (symbol? (car args)) + (symbol->string (car args)) + (car args))) + (widget-class (if arg-list-even? + (widgetClass-XwidgetClass (car args)) + (widgetClass-XwidgetClass (cadr args)))) + (parent (if arg-list-even? + (widget-Xwidget (cadr args)) + (widget-Xwidget (caddr args)))) + (new-widget (%create-widget widget-name widget-class parent + real-arg-list num-args + managed?))) + (make-widget new-widget)))) + + +(import-lambda-definition %create-widget (String, XWidgetClass, XWidget, + args, Cardinal, flag) + "scxt_Create_Widget") + + + +(define (realize-widget widget) + (if (get-free widget) + (error "wrong widget" realize-widget) + (%realize-widget (widget-Xwidget widget)))) + +(import-lambda-definition %realize-widget (XWidget) + "sctx_Realize_Widget") + + + +(define (unrealize-widget widget) + (if (get-free widget) + (error "wrong widget" unrealize-widget) + (%unrealize-widget (widget-Xwidget widget)))) + +(import-lambda-definition %unrealize-widget (XWidget) + "sctx_Unrealize_Widget") + + +(define (widget-realized? widget) + (if (get-free widget) + (error "wrong widget" widget-realized?) + (%widget-realized? (widget-Xwidget widget)))) + +(import-lambda-definition %widget-realized? (XWidget) + "sctx_Widget_Realized_P") + + +;; Attention! I don't know if the use of the finalizer in make-display +;; is correct. + +(define (widget-display widget) + (if (get-free widget) + (error "wrong widget" widget-display) + (make-display (%widget-display (widget-Xwidget widget)) #f))) + +(import-lambda-definition %widget-display (XWidget) + "sctx_Widget_Display") + + +;; Returns the parent widget... + +(define (widget-parent widget) + (if (get-free widget) + (error "wrong widget" widget-parent) + (%widget-parent (widget-Xwidget widget)))) + +(import-lambda-definition %widget-parent (Xwidget) + "scxt_Widget_Parent") + +;; Returns the name of the widget as a string. +(define (widget-name widget) + (if (get-free widget) + (error "wrong widget" widget-name) + (%widget-parent (widget-Xwidget widget)))) + +(import-lambda-definition %widget-name (Xwidget) + "scxt_Widget_Name") + + +;; Returns the window associated with the widget +(define (widget->window widget) + (if (get-free widget) + (error "wrong widget" widget->window) + (%widget->window (widget-Xwidget widget)))) + +(import-lambda-definition %widget->window (Xwidget) + "scxt_Widget_To_Window") + + + +;; (define (widget-window widget)) ????? + + +(define (widget-compsite? widget) + (if (get-free widget) + (error "freed widget" widget-composite?) + (%widget-composite? (widget-Xwidget widget)))) + +(import-lambda-definition %widget-composite? (Xwidget) + "scxt_Widget_Composite_P") + + +;; internal function: +(define (help-wlist-get-free widget-list) + (letrec ((loop + (lambda (tsil) + (cond + ((null? tsil) #f) + ((get-free (car tsil)) #t) + (else + (loop (cdr tsil))))))) + (loop widget-list))) + +;; int. function: +(define (help-wlist-widget-Xwidget widget-list) + (letrec ((loop + (lambda (new-list old-list) + (if (null? old-list) + new-list + (loop (cons (widget-Xwidget (car old-list)) new-list) + (cdr old-list)))))) + (loop '() widget-list))) + + +(define magage-children + (lambda widget-list + (if (help-wlist-get-free widget-list) + (error "free widget" manage-children) + (%manage-children (help-wlist-widget-Xwidget widget-list) + (length widget-list))))) + +(import-lambda-definition %manage-children (Xwidget-list list-length) + "scxt_Manage_Children") + + +(define (manage-child widget) + (manage-children widget)) + + +(define (unmanage-child widget) + (unmanage-children widget)) + + +(define unmanage-children + (lambda widget-list + (if (help-wlist-get-free widget-list) + (error "free widget" unmanage-children) + (%unmanage-children (help-wlist-widget-Xwidget widget-list) + (length widget-list))))) + +(import-lambda-definition %unmanage-children (Xwidget-list list-length) + "scxt_Unmanage_Children") + + +(define (widget-managed? widget) + (if (get-free widget) + (error "free widget" widget-managed?) + (%widget-managed? (widget-Xwidget widget)))) + +(import-lambda-definition %widget-managed? (Xwidget) + "scxt_Widget_Managed_P") + + +(define (widget-class widget) + (if (get-free widget) + (error "free widget" widget-class) + (%widget-class (widget-Xwidget widget)))) + +(import-lambda-definition %widget-class (Xwidget) + "scxt_Widget_Class") + + +(define (widget-superclass widget) + (if (get-free widget) + (error "free widget" widget-superclass) + (let ((res (%widget-superclass (widget-Xwidget widget)))) + (if res res 'none)))) + +(import-lambda-definition %widget-superclass (Xwidget) + "scxt_Widget_Superclass") + + +;; TODO: class parameter: check neccessary? +(define (widget-subclass? widget wclass) + (if (get-free widget) + (error "free widget" widget-subclass?) + (%widget-subclass? (widget-Xwidget widget) (wclass-Xwclass wclass)))) + +(imoport-lambda-definition %widget-subclass? (Xwidget Xwclass) + "scxt_Widget_Subclass_P") + + +(define (set-mapped-when-managed! widget managed?) + (if (get-free widget) + (error "free widget" set-mapped-when-managed!) + (%set-mapped-when-managed! (widget-Xwidget widget) managed?))) + +(import-lambda-definition %set-mapped-when-managed! (Xwindget bool) + "scxt_Set_Mapped_When_Managed") + + +(define (map-widget widget) + (if (get-free widget) + (error "free widget" map-widget) + (%map-widget (widget-Xwidget widget)))) + +(import-lambda-definition %map-widget (Xwidget) + "scxt_Map_Widget") + + +(define (unmap-widget widget) + (if (get-free widget) + (error "free widget" unmap-widget) + (%unmap-widget (widget-Xwidget widget)))) + +(import-lambda-definition %unmap-widget (Xwidget) + "scxt_Unmap_Widget") + + +;; values consists of a widget and ressource arguments: +;; (the 1,3,5,.. a name to be set and the 2, 4, 6, ... the corresponding value) +(define set-values! + (lambda values + (let ((widget (car values)) + (args (help-arg-list-symbol->string (cdr values)))) + (if (get-free widget) + (error "free widget" set-values!) + (%set-values! (widget-Xwidget widget) args (/ (length args) 2)))))) + +(import-lambda-definition %set-args (Xwidget arg-list num-args) + "scxt_Set_Values") + + +;; the args are the wanted ressource names... +(define get-values + (lambda values + (let ((widget (car values)) + (args (map help-maybe-string->symbol (cdr values)))) + (if (get-free widget) + (error "free widget" get-values) + (%get-values (widget-Xwidget widget) args (length args)))))) + + +(import-lambda-definition %get-values (Xwidget arg-list num-args) + "scxt_Get_Values") + + + +(define (widget-context widget) + (if (get-free widget) + (error "free widget" widget-context) + (%widget-context (widget-Xwidget widget)))) + +(import-lambda-definition %widget-context (Xwidget) + "scxt_Widget_Context") + + + + + +(define (set-sensitive! widget sensitive?) + (if (get-free widget) + (error "free widget" set-sensitive!) + (%set-sensitive! (widget-Xwidget widget) sensitive?))) + +(import-lambda-definition %set-sensitive! (Xwidget boolean) + "scxt_Set_Sensitive") + + + + + +(define (widget-sensitive? widget) + (if (get-free widget) + (error "free widget" widget-sensitive?) + (%widget-sensitive? (widget-Xwidget widget)))) + +(import-lambda-definition %widget-sensitive? (Xwidget) + "scxt_Widget_Sensitive_P") + + + + +(define (window->widget window) + (make-widget + (%window->widget (window-Xwindow window) + (display-Xdisplay (window-display window))))) + +(import-lambda-definition %window->widget (Xwindow Xdisplay) + "scxt_Window_To_Widget") + + +;; returns the widget with the specified name and which is a +;; child of the root-widget. name is either a symbol or a string. +;; If no widget is found, NULL will be returned. +(define (name->widget root-widget name) + (if (get-free root-widget) + (error "free widget" name->widget) + (make-widget + (%name->widget (widget-Xwidget root-widget) + (help-maybe-symbol->string name))))) + +(import-lambda-definition %name->widget (Xwidget string) + "scxt_Name_To_Widget") + + +;; returns a pair of integers, which represent the coordinates +;; relative to it's root-widget. +(define (widget-translate-coordinates widget x y) + (if (get-free widget) + (error "free widget" widget-translate-coordinates) + (%widget-translate-coordinates (widget-Xwidget widget) x y))) + +(import-lambda-definition %widget-translate-coordinates (Xwidget int-x int-y) + "scxt_Widget_Translate_Coordinates")