From 48045387bf2e23b92110be50a59836f1cf3a8e5c Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Thu, 21 Mar 1996 16:52:57 +0000 Subject: [PATCH] Tidied the interface between WIN32-SCREENs and edwin commands. Modified Edwin commands SET-ICON. Added Edwin commands SET-FOREGROUND-COLOR SET-BACKGROUND-COLOR SET-FONT SET-DEFAULT-FONT SET-SCREEN-POSITION SHOW-SCREEN-SIZE SHOW-SCREEN-POSITION --- v7/src/edwin/edwin.pkg | 17 ++++++-- v7/src/edwin/win32.scm | 39 +++++++++++++++++-- v7/src/edwin/win32com.scm | 82 +++++++++++++++++++++++++++++++++++---- 3 files changed, 124 insertions(+), 14 deletions(-) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index fbf25405a..9d3e89227 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.183 1995/11/04 02:29:00 cph Exp $ +$Id: edwin.pkg,v 1.184 1996/03/21 16:52:41 adams Exp $ Copyright (c) 1989-95 Massachusetts Institute of Technology @@ -1120,19 +1120,30 @@ MIT in each case. |# (import (win32) destroy-window get-handle + get-window-rect load-icon + make-rect rect/top rect/left rect/bottom rect/right message-beep send-message set-active-window set-focus + set-window-pos set-window-text sleep show-window sw_showminnoactive + SWP_NOSIZE + SWP_NOZORDER update-window) (export (edwin win-commands) - screen->handle - win32-screen/set-name!) + win32-screen/get-position + win32-screen/set-name! + win32-screen/set-font! + win32-screen/set-icon! + win32-screen/set-size! + win32-screen/set-position! + win32-screen/set-foreground-color! + win32-screen/set-background-color!) (initialization (initialize-package!))) (define-package (edwin win32-keys) diff --git a/v7/src/edwin/win32.scm b/v7/src/edwin/win32.scm index 9ef91a818..76b8f8b3e 100644 --- a/v7/src/edwin/win32.scm +++ b/v7/src/edwin/win32.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: win32.scm,v 1.4 1995/06/28 23:29:17 adams Exp $ +;;; $Id: win32.scm,v 1.5 1996/03/21 16:52:57 adams Exp $ ;;; -;;; Copyright (c) 1994 Massachusetts Institute of Technology +;;; Copyright (c) 1994-96 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -59,7 +59,11 @@ (win32-screen-write-substring! 7) (win32-screen-show-cursor! 2) (win32-screen-current-focus 0) - (win32-screen-set-icon! 2)) + (win32-screen-set-icon! 2) + (win32-screen-set-default-font! 1) + (win32-screen-set-font! 2) + (win32-screen-set-foreground-color! 2) + (win32-screen-set-background-color! 2)) (define-integrable event:process-output 16) (define-integrable event:process-status 32) @@ -590,3 +594,32 @@ (begin (set-screen-name! screen name) (set-window-text (screen->handle screen) name))))) + +(define (win32-screen/set-font! screen font) + (win32-screen-set-font! (screen->handle screen) font)) + +(define (win32-screen/set-icon! screen icon) + (win32-screen-set-icon! (screen->handle screen) icon)) + +(define (win32-screen/set-foreground-color! screen color) + (win32-screen-set-foreground-color! (screen->handle screen) color)) + +(define (win32-screen/set-background-color! screen color) + (win32-screen-set-background-color! (screen->handle screen) color)) + +;; Missing functionality: to specify the screen's size in characters +;; +;;(define (win32-screen/set-size! screen width height) +;; (?? (screen->handle screen) width height) +;; (update-screen! screen #T)) + +(define (win32-screen/set-position! screen x y) + (set-window-pos (screen->handle screen) 0 0 0 + x y + (+ SWP_NOSIZE SWP_NOZORDER))) + +(define (win32-screen/get-position screen) + (let ((rect (make-rect 0 0 0 0))) + (get-window-rect (screen->handle screen) rect) + (values (rect/left rect) (rect/top rect) + (rect/right rect) (rect/bottom rect)))) \ No newline at end of file diff --git a/v7/src/edwin/win32com.scm b/v7/src/edwin/win32com.scm index 42aa6fbe6..263612333 100644 --- a/v7/src/edwin/win32com.scm +++ b/v7/src/edwin/win32com.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: win32com.scm,v 1.3 1994/11/06 18:36:57 adams Exp $ +;;; $Id: win32com.scm,v 1.4 1996/03/21 16:52:48 adams Exp $ ;;; -;;; Copyright (c) 1994 Massachusetts Institute of Technology +;;; Copyright (c) 1994-1996 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -44,9 +44,6 @@ (declare (usual-integrations)) -(define (current-win32-window) - (screen->handle (selected-screen))) - (define-command set-icon "Set the current window's icon to ICON. ICON must be the (string) name of one of the known icons. @@ -59,9 +56,7 @@ When called interactively, completion is available on the input." (let ((icon (load-icon (get-handle 0) icon-name))) (if (zero? icon) (error "Unknown icon name" icon-name) - ((ucode-primitive win32-screen-set-icon! 2) - (current-win32-window) - icon))))) + (win32-screen/set-icon! (selected-screen) icon))))) (define icon-names '#("shield3_icon" @@ -82,6 +77,77 @@ When called interactively, completion is available on the input." "bch_ico")) +(define-command set-foreground-color + "Set foreground (text) color to COLOR." + "sSet foreground color" + (lambda (name) + (let ((screen (selected-screen))) + (win32-screen/set-foreground-color! screen (win32/find-color name)) + (update-screen! screen #t)))) + +(define-command set-background-color + "Set background (text) color to COLOR." + "sSet background color" + (lambda (name) + (let ((screen (selected-screen))) + (win32-screen/set-background-color! screen (win32/find-color name)) + (update-screen! screen #t)))) + +(define-command set-font + "Set font to be used for drawing text." + "sSet font" + (lambda (font) + (let ((screen (selected-screen))) + (win32-screen/set-font! screen font) + (update-screen! screen #t)))) + +(define-command set-default-font + "Set font to be used for drawing text in new windows." + "sSet default font" + (lambda (font) + ((ucode-primitive win32-screen-set-default-font! 1) font))) + +;; Missing functionality in win32-screen. +;;(define-command set-screen-size +;; "Set size of editor screen to WIDTH x HEIGHT." +;; "nScreen width (chars)\nnScreen height (chars)" +;; (lambda (width height) +;; (win32-screen/set-size! (selected-screen) (max 2 width) (max 2 height)))) + +(define-command set-screen-position + "Set position of editor screen to (X,Y)." + "nX position (pels)\nnY position (pels)" + (lambda (x y) + (win32-screen/set-position! (selected-screen) x y))) + +(define-command show-screen-size + "Show size of editor screen." + () + (lambda () + (let ((screen (selected-screen))) + (call-with-values (lambda () (win32-screen/get-position screen)) + (lambda (x y r b) + (message "Screen is " + (screen-x-size screen) + " chars wide and " + (screen-y-size screen) + " chars high (" + (- r x) "x" (- b y) + " pels)")))))) + +(define-command show-screen-position + "Show position of editor screen. +This is the position of the upper left-hand corner of the frame border +surrounding the screen, relative to the upper left-hand corner of the +desktop." + () + (lambda () + (call-with-values (lambda () (win32-screen/get-position (selected-screen))) + (lambda (x y r b) + r b ; ignored + (message "Screen's upper left-hand corner is at (" x "," y ")"))))) + + (define (update-win32-screen-name! screen) (let ((window -- 2.25.1