;;; -*- Mode:COMMON-LISP; Package:X11; Base:10.; Fonts:(MEDFNB hl12B hl12bi) -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved. ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 05/10/89 DAN Fix CREATE-GLYPH-CURSOR to handle mask-font of 0. ;;; 01/18/89 LGO In create-glyph-cursor, allow a mask-font of none. ;;; 01/10/89 WJB 1In CREATE-CURSOR, if no mask supplied use width and height from source pixmap.* ;;; 12/21/88 LGO 1Get rid of MAKE-ROOT-CURSOR.* ;;; 12/21/88 LGO Make the root cursor's colors positive. ;;; 10/18/88 LGO Comment out the body of FREE-CURSOR to keep it from causing errors ;;; 8/15/88 WJB Changed CREATE-ROOT-CURSOR to not make any resources. Don't know ;;; why any resources would be needed plus this allows creating cursor before ;;; client connection established. ;;; Dunno if this is correct, but am trying to get cursor intialization to work. ;;; 7/25/88 DAN Coded CREATE-CURSOR, CREATE-ROOT-CURSOR, MAKE-ROOT-CURSOR, ;;; FREE-CURSOR, CREATE-GLYPH-CURSOR, and RECOLOR-CURSOR. ;;; 4/26/88 TWE Wrote stubbed versions of FREE-CURSOR and MAKE-ROOT-CURSOR. ;;; 12/15/87 TWE Moved requests from the REQUESTS file. (defreq Create-Cursor ((cursor NEWID) (source PIXMAP) (mask (ONEOF PIXMAP)) (fore-red CARD16) (fore-green CARD16) (fore-blue CARD16) (back-red CARD16) (back-green CARD16) (back-blue CARD16) (x CARD16) (y CARD16)) (WHEN (EQL mask UNIVERSAL-NONE) (SETQ mask nil)) (create-cursor state cursor source mask fore-red fore-green fore-blue back-red back-green back-blue x y)) (DEFUN create-cursor (client cid source mask fred fgreen fblue bred bgreen bblue x y) (DECLARE (IGNORE client)) (LET* ((src-width (pixmap.width source)) (src-height (pixmap.height source)) (src-depth (drawable-depth source)) (msk-width (IF mask (pixmap.width mask) src-width)) (msk-height (IF mask (pixmap.height mask) src-height)) (msk-depth (IF mask (drawable-depth mask) src-depth)) (srcbits (create-pixmap-array src-width src-height 1)) (mskbits (create-pixmap-array msk-width msk-height 1 1)) ;1;Give mskbits an initial value of all 1's, so if mask if nil all pixels of the source will be displayed.* cursor) (COND ((AND mask (OR (NOT (= src-width msk-width)) (NOT (= src-height msk-height)) (NOT (= src-depth msk-depth 1)))) (bad-match)) ((OR (> x src-width) (> y src-height)) (bad-match)) (t ;1ELSE* (COPY-ARRAY-CONTENTS (pixmap.array source) srcbits) (WHEN mask (COPY-ARRAY-CONTENTS (pixmap.array mask) mskbits)) )) (SETQ cursor (make-cursor-record :id cid :type cursor-resource-type :source srcbits :mask mskbits :width src-width :height src-height :xhot x :yhot y :fore-red fred :fore-green fgreen :fore-blue fblue :back-red bred :back-green bgreen :back-blue bblue)) (add-resource cid cursor))) (DEFUN create-root-cursor (font-name glyph) "2Looks up the name of a font and opens it.* 2Makes bitmaps from *GLYPH2 and *GLYPH + 12 of the font, then makes* 2a cursor from the bitmaps and *returns 2the cursor.*" (LET ((cursor (make-cursor-record)) (font-ID (funcall simple-resource-id-function)) cursor-font) (SETQ cursor-font (open-font font-ID font-name (LENGTH font-name) 0 nil)) (COND ((OR (NULL cursor-font) (NULL (SETQ cursor (cursor-metrics-from-glyph cursor-font (1+ glyph))))) NIL) (t ;1;This assumes that the font is defined to have source and mask pairs for each glyph.* (SETF (cursor-record.source cursor) (server-bits-from-glyph cursor-font glyph cursor)) (SETF (cursor-record.mask cursor) (server-bits-from-glyph cursor-font (1+ glyph) cursor)) (SETF (cursor-record.fore-red cursor) 0) (SETF (cursor-record.fore-green cursor) 0) (SETF (cursor-record.fore-blue cursor) 0) (SETF (cursor-record.back-red cursor) (1- (expt 2 16))) (SETF (cursor-record.back-green cursor) (1- (expt 2 16))) (SETF (cursor-record.back-blue cursor) (1- (expt 2 16))) ;;(SETQ cursor-id (funcall simple-resource-id-function)) ;;(SETF (cursor-record.id cursor) cursor-id) (SETF (cursor-record.type cursor) cursor-resource-type) ;;(add-resource cursor-id cursor) cursor)))) (defreq Create-Glyph-Cursor ((cursor NEWID) (source-font FONT) (mask-font (oneof FONT)) (source-char CARD16) (mask-char CARD16) (fore-red CARD16) (fore-green CARD16) (fore-blue CARD16) (back-red CARD16) (back-green CARD16) (back-blue CARD16)) (create-glyph-cursor cursor source-font mask-font source-char mask-char fore-red fore-green fore-blue back-red back-green back-blue)) (DEFUN create-glyph-cursor (cursor-id source-font mask-font source-char mask-char fore-red fore-green fore-blue back-red back-green back-blue) (LET* (cm) (IF (AND (NUMBERP mask-font) (= mask-font 0)) (SETQ mask-font nil)) (COND ((NULL (setq cm (cursor-metrics-from-glyph source-font source-char))) (bad-value source-char)) ((and mask-font (NULL (SETQ cm (cursor-metrics-from-glyph mask-font mask-char)))) (bad-value mask-char)) (t1 * ;;ELSE (add-resource cursor-id (make-cursor-record :id cursor-id :type cursor-resource-type :source (server-bits-from-glyph source-font source-char cm) :mask (server-bits-from-glyph (or mask-font source-font) (and mask-font mask-char) cm) :width (cursor-record.width cm) :height (cursor-record.height cm) :xhot (cursor-record.xhot cm) :yhot (cursor-record.yhot cm) :fore-red fore-red :fore-green fore-green :fore-blue fore-blue :back-red back-red :back-green back-green :back-blue back-blue)))))) (defreq Free-Cursor ((:solo) (cursor CURSOR)) (free-cursor cursor)) (DEFUN FREE-CURSOR (cursor) (comment ;1; *cursor-record.ref-count1 is not maintained - LGO* (COND ((> (DECF (cursor-record.ref-count cursor)) 0) Status-Success) (t (LOOP for ncsr from 0 below (screen-info.num-screens screen-info) for scr in (screen-info.screens screen-info) do (explorer-unrealize-cursor scr cursor))))) (remove-resource (cursor-record.id cursor))) (defreq Recolor-Cursor ((cursor CURSOR) (fore-red CARD16) (fore-green CARD16) (fore-blue CARD16) (back-red CARD16) (back-green CARD16) (back-blue CARD16)) (recolor-cursor cursor fore-red fore-green fore-blue back-red back-green back-blue)) (DEFUN recolor-cursor (cursor fred fgreen fblue bred bgreen bblue) (SETF (cursor-record.fore-red cursor) fred) (SETF (cursor-record.fore-green cursor) fgreen) (SETF (cursor-record.fore-blue cursor) fblue) (SETF (cursor-record.back-red cursor) bred) (SETF (cursor-record.back-green cursor) bgreen) (SETF (cursor-record.back-blue cursor) bblue) (LOOP for ncsr from 0 below (screen-info.num-screens screen-info) for scr in (screen-info.screens screen-info) do (explorer-recolor-cursor scr cursor (AND (EQ cursor (sprite.current sprite)) (EQ scr current-screen)))))