From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 21 Mar 1996 16:52:57 +0000 (+0000)
Subject: Tidied the interface between WIN32-SCREENs and edwin commands.
X-Git-Tag: 20090517-FFI~5640
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=48045387bf2e23b92110be50a59836f1cf3a8e5c;p=mit-scheme.git

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
---

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