149 lines
4.6 KiB
Scheme
149 lines
4.6 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Win32 Commands
|
||
;;; package (edwin win-commands)
|
||
|
||
|
||
|
||
(define-command set-icon
|
||
"Set the current window's icon to ICON.
|
||
ICON must be the (string) name of one of the known icons.
|
||
When called interactively, completion is available on the input."
|
||
(lambda ()
|
||
(list (prompt-for-alist-value "Set Icon"
|
||
(map (lambda (x) (cons x x))
|
||
(vector->list icon-names)))))
|
||
(lambda (icon-name)
|
||
(let ((icon (load-icon (get-handle 0) icon-name)))
|
||
(if (zero? icon)
|
||
(error "Unknown icon name" icon-name)
|
||
(win32-screen/set-icon! (selected-screen) icon)))))
|
||
|
||
(define icon-names
|
||
'#("shield3_icon"
|
||
"shield4_icon"
|
||
"shield2_icon"
|
||
"shield1_icon"
|
||
"lambda_icon"
|
||
"lambda2_icon"
|
||
"edwin_icon"
|
||
"liar1_icon"
|
||
"liar2_icon"
|
||
"liar3_icon"
|
||
"graphics_icon"
|
||
"coffee_icon"
|
||
"conses_icon"
|
||
"environment_icon"
|
||
"mincer_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 frames."
|
||
"sSet default font"
|
||
(lambda (font)
|
||
((ucode-primitive win32-screen-set-default-font! 1) font)))
|
||
|
||
(define-command set-frame-size
|
||
"Set size of editor frame to WIDTH x HEIGHT."
|
||
"nFrame width (chars)\nnFrame height (chars)"
|
||
(lambda (width height)
|
||
(win32-screen/set-size! (selected-screen) (max 2 width) (max 2 height))))
|
||
|
||
(define-command set-frame-position
|
||
"Set position of editor frame to (X,Y)."
|
||
"nFrame X position (pels)\nnFrame Y position (pels)"
|
||
(lambda (x y)
|
||
(win32-screen/set-position! (selected-screen) x y)))
|
||
|
||
(define-command show-frame-size
|
||
"Show size of current frame."
|
||
()
|
||
(lambda ()
|
||
(let ((screen (selected-screen)))
|
||
(call-with-values (lambda () (win32-screen/get-client-size screen))
|
||
(lambda (width height)
|
||
(message "Frame is "
|
||
(screen-x-size screen)
|
||
" chars wide and "
|
||
(screen-y-size screen)
|
||
" chars high ("
|
||
width "x" height
|
||
" pels)"))))))
|
||
|
||
(define-command show-frame-position
|
||
"Show position of current frame.
|
||
This is the position of the upper left-hand corner of the frame border
|
||
surrounding the frame, 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 "Frame's upper left-hand corner is at (" x "," y ")")))))
|
||
|
||
(define (update-win32-screen-name! screen)
|
||
(let ((window
|
||
(if (and (selected-screen? screen) (within-typein-edit?))
|
||
(typein-edit-other-window)
|
||
(screen-selected-window screen))))
|
||
(let ((buffer (window-buffer window))
|
||
(update-name
|
||
(lambda (set-name format length)
|
||
(if format
|
||
(set-name
|
||
screen
|
||
(string-trim-right
|
||
(format-modeline-string window format length)))))))
|
||
(update-name win32-screen/set-name!
|
||
(ref-variable frame-name-format buffer)
|
||
(ref-variable frame-name-length buffer)))))
|