;;; ;;; Copyright 1990 by Digital Equipment AB, Sweden ;;; ;;; and ;;; ;;; Hakan Huss and Johan Ihren ;;; ;;; All Rights Reserved ;;; ;;; Permission to use, copy, modify, and distribute this software and ;;; its documentation for any purpose and without fee is hereby ;;; granted, provided that the above copyright notice appear in all ;;; copies and that both that copyright notice and this permis- ;;; sion notice appear in supporting documentation, and that the ;;; names of the copyright holders not be used in advertising in ;;; publicity pertaining to distribution of the software without ;;; specific, written prior permission. The copyright holders make no ;;; representations about the suitability of this software for any ;;; purpose. It is provided "as is" without express or implied warranty. ;;; ;;; THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO ;;; THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT- ;;; ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS ;;; BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR ;;; PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE ;;; OR PERFORMANCE OF THIS SOFTWARE. ;;; ;;; Authors: Hakan Huss, KTH and Johan Ihren, KTH ;;; ;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/lw-objects.sc,v 1.5 90/04/01 13:50:31 johani Exp $ ;;; SCIX Light-weight objects. (module lwobjects (top-level make-resource make-pointer make-keyboard make-color make-polypoint make-polyline make-polysegment make-polyrectangle make-polyarc make-fillpoly make-polyfillrectangle make-polyfillarc make-polytext8 make-polytext16 make-imagetext8 make-imagetext16 make-view)) (include "../include/types.sch") ; Used by the xas-contents in color. (include "../include/requests.sch") (include "../include/util.sch") (define-external x-reply? msghandler) (include "../macros/extend-syntax.sc") (include "../macros/define-lw-class.sc") (include "graphic-objects.sc") (include "view-object.sc") ;;; Resources -- drawables (windows and pixmaps), cursors, fonts, gcontexts ;;; and colormaps. If it wasn't for the init, we could have made ;;; resource a light-weight class, which would have been nice. ;;; An init will be provided in the light-weight objects soon... (define-lw-class (resource scr id) (methods (id (lambda () id)) (scix-announce-id! (lambda (o) ((scr 'scix-id-vector) 'insert-with-key! o id) )) (scix-denounce-id! (lambda () ((scr 'scix-id-vector) 'remove! me) )) ) (init (if (not id) (set! id (scr 'scix-unique-id)) ))) ;;; Pointers. ;;; (define-lw-class (pointer scr) ;; We always set both do-acc and-do-threshold flags to keep things simple. (methods (grabpointer (lambda (owner-ev grab-win ev-mask ptr-mode ; #26: GrabPointer kbd-mode confine-to cursor time . rest) (send-grabpointer owner-ev grab-win ev-mask ptr-mode kbd-mode confine-to cursor time scr rest))) (ungrabpointer (lambda (time . rest) ; #27: UnGrabPointer (send-ungrabpointer time scr rest) )) (changeactivepointergrab (lambda (cursor time ev-mask . rest) ; #30 (send-changeactivepointergrab cursor time ev-mask scr rest))) (changepointercontrol (lambda (acc-num acc-den threshold do-acc do-thr . rest) ; #105 (send-changepointercontrol acc-num acc-den threshold do-acc do-thr scr rest) )) (getpointercontrol (lambda rest ; #106 (send-getpointercontrol scr rest) )) (setpointermapping (lambda (map . rest) ; #116 (send-setpointermapping map scr rest) )) (getpointermapping (lambda rest ; #117 (send-getpointermapping scr rest) )) (warppointer (lambda (src-win dst-win src-x src-y ; #41 : WarpPointer src-width src-height dst-x dst-y . rest) (send-warppointer src-win dst-win src-x src-y src-width src-height dst-x dst-y scr rest) )) )) ;;; Keyboards. ;;; (define-lw-class (keyboard scr) (methods ;; This is certain to change. At present we just want to ensure that the ;; dispatch works correctly. (scix-event-dispatch (lambda (ev-source obj) (let ((e (ev-source 'next-event!))) (format #t "Keyboard: recieved a ~a-event.~%" (e 'event-name) ) (flush-buffer) ))) ;; Methods directly mapped on X requests (grabkeyboard (lambda (owner-ev grab-win time ; #31 : GrabKeyboard pntr-mode kbd-mode . rest) (let ((r (send-grabkeyboard owner-ev grab-win time pntr-mode kbd-mode scr rest))) (if (x-reply? r) (r 'status) r)))) (ungrabkeyboard (lambda (time . rest) ; #32 : UngrabKeyboard (send-ungrabkeyboard time scr rest) )) (querykeymap (lambda rest ; #44: QueryKeymap (send-querykeymap scr rest) )) (changekeyboardmapping (lambda (first-kc keysyms . rest) ; #100 (send-changekeyboardmapping first-kc keysyms scr rest) )) (getkeyboardmapping (lambda (first-kc count . rest) ; #101 (send-getkeyboardmapping first-kc count scr rest) )) (changekeyboardcontrol (lambda (data . rest) ; #102 (send-changekeyboardcontrol data scr rest) )) (getkeyboardcontrol (lambda rest ; #103 (send-getkeyboardcontrol scr rest) )) (setmodifiermapping (lambda (keycodes . rest) ; #118 (let ((reply (send-setmodifiermapping keycodes scr rest))) (if (x-reply? reply) (reply 'status) reply) ))) (getmodifiermapping (lambda rest ; #119: GetModifierMapping (let ((reply (send-getmodifiermapping scr rest))) (let loop ((l (reply 'keycodes)) (size (reply 'keycodes-per-modifier)) ) (if (null? l) '() (let ((start (cons l '())) (tail (list-tail l (- size 1))) ) (set-cdr! start (loop (cdr tail) size)) (set-cdr! tail '()) start)))))) )) ;;; Colors. ;;; Note: Strictly speaking, the pixel-value should be single-assignment, as ;;; it is set by the function that returns the color object (usually a ;;; method in a colormap object). But it has proven useful (i e in the ;;; color-wheel-demo) to be able to reassign it. So, with the philosophy ;;; that "it is better to provide mechanism than policy", we leave it ;;; that way. ;;; (define-lw-class (color red green blue) (locals (visual-red #f) (visual-green #f) (visual-blue #f) (name "") (cmap #f) (pixel #f) (flags '(do-red do-green do-blue))) (methods (red (lambda () red)) (set-red! (lambda (r) (set! red r))) (green (lambda () green)) (set-green! (lambda (g) (set! green g))) (blue (lambda () blue)) (set-blue! (lambda (b) (set! blue b))) (visual-red (lambda () visual-red)) (set-visual-red! (lambda (r) (set! visual-red r))) (visual-green (lambda () visual-green)) (set-visual-green! (lambda (g) (set! visual-green g))) (visual-blue (lambda () visual-blue)) (set-visual-blue! (lambda (b) (set! visual-blue b))) (name (lambda () name)) (set-name! (lambda (n) (set! name n))) (flags (lambda () flags)) (set-flags! (lambda (f) (set! flags f))) (do-mask (lambda () (bit-or (if (memq 'do-red flags) #x01 0) (if (memq 'do-green flags) #x02 0) (if (memq 'do-blue flags) #x04 0) ))) (pixel (lambda () pixel)) (set-pixel! (lambda (p) (set! pixel p))) (colormap (lambda () cmap)) (set-colormap! (lambda (m) (set! cmap m))) ))