2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-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)
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(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)
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(ref-variable frame-name-length buffer)))))
|