#| -*-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
(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)
;;; -*-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
(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)
(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
;;; -*-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
(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.
(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"
"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
projects / mit-scheme.git / commitdiff