From 0cdcedd1e5fda98f666f9493a9b06505296bf7d4 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 13 Jun 1996 13:14:45 +0000
Subject: [PATCH] Initial revision

original commit: 6155845eea0c0f1310ce4f106f0f51200cc06b57
---
 collects/mred/edit.ss   | 230 +++++++++++++
 collects/mred/exit.ss   |  36 ++
 collects/mred/finder.ss | 432 +++++++++++++++++++++++
 collects/mred/keys.ss   | 746 ++++++++++++++++++++++++++++++++++++++++
 4 files changed, 1444 insertions(+)
 create mode 100644 collects/mred/edit.ss
 create mode 100644 collects/mred/exit.ss
 create mode 100644 collects/mred/finder.ss
 create mode 100644 collects/mred/keys.ss

diff --git a/collects/mred/edit.ss b/collects/mred/edit.ss
new file mode 100644
index 00000000..87b4b083
--- /dev/null
+++ b/collects/mred/edit.ss
@@ -0,0 +1,230 @@
+(define-sigfunctor (mred:edit@ mred:edit^)
+  (import mred:finder^ mred:path-utils^ mred:mode^ mred:scheme-paren^ 
+	  mred:keymap^ mzlib:function^)
+
+  (define make-std-buffer%
+    (lambda (buffer%)
+      (class buffer% args
+	(inherit modified? get-filename save-file set-max-width)
+	(rename
+	 [super-set-filename set-filename]
+	 [super-set-modified set-modified]
+	 [super-on-change on-change]
+	 [super-on-save-file on-save-file])
+	(private
+	 [auto-saved-name #f]
+	 [auto-save-out-of-date? #t]
+	 [auto-save-error? #f])
+	(public
+	 [get-file (lambda (d) (let ([v (mred:finder^:get-file d)])
+				 (if v
+				     v
+				     '())))]
+	 [put-file (lambda (d f) (let ([v (mred:finder^:put-file f d)])
+				   (if v
+				       v
+				       '())))]
+	 
+	 [auto-set-wrap? #f]
+	 [set-auto-set-wrap
+	  (lambda (v)
+	    (set! auto-set-wrap? v)
+	    (if (not v)
+		(set-max-width -1)))]
+	
+	 [active-canvas #f]
+	 [set-active-canvas
+	  (lambda (c)
+	    (set! active-canvas c))]
+
+	 [canvases '()]
+	 [add-canvas
+	  (lambda (canvas)
+	    (set! canvases (cons canvas canvases)))]
+	 [remove-canvas
+	  (lambda (canvas)
+	    (set! canvases (mzlib:function^:remove canvas canvases)))]
+	 
+	 [mode #f]
+	 [set-mode
+	  (lambda (m)
+	    #f)]
+	 
+	 [set-modified
+	  (lambda (modified?)
+	    (if auto-saved-name
+		(if (not modified?)
+		    (begin
+		      (delete-file auto-saved-name)
+		      (set! auto-saved-name #f))
+		    (set! auto-save-out-of-date? #t)))
+	    (super-set-modified modified?)
+	    (for-each (lambda (canvas) (send canvas edit-modified modified?))
+		      canvases))]
+	 [set-filename
+	  (opt-lambda (name [temp? #f])
+		      (super-set-filename name temp?)
+		      (for-each (lambda (canvas) (send canvas edit-renamed name))
+				canvases))]
+
+	 [on-change
+	  (lambda ()
+	    (super-on-change)
+	    (set! auto-save-out-of-date? #t))]
+	 [auto-save? #t]
+	 [do-autosave
+	  (lambda ()
+	    (when (and auto-save?
+		       (not auto-save-error?)
+		       (modified?)
+		       (or (not auto-saved-name)
+			   auto-save-out-of-date?))
+	      (let* ([orig-name (get-filename)]
+		     [auto-name (mred:path-utils^:generate-autosave-name orig-name)]
+		     [success (save-file auto-name wx:const-media-ff-copy)])
+		(if success
+		    (begin
+		      (if auto-saved-name
+			  (delete-file auto-saved-name))
+		      (set! auto-saved-name auto-name)
+		      (set! auto-save-out-of-date? #f))
+		    (begin
+		      (wx:message-box 
+		       (format "Error autosaving ~s.~n~a~n~a"
+			       (if (null? orig-name) "Untitled" orig-name)
+			       "Autosaving is turned off"
+			       "until the file is saved.")
+		       "Warning")
+		      (set! auto-save-error? #t))))))]
+	 [remove-autosave
+	  (lambda ()
+	    (when auto-saved-name
+		  (delete-file auto-saved-name)
+		  (set! auto-saved-name #f)))]
+
+	 [backup? #t]
+	 [on-save-file
+	  (lambda (name format)
+	    (set! auto-save-error? #f)
+	    (if (super-on-save-file name format)
+		(begin
+		  (if (and backup?
+			   (not (= format wx:const-media-ff-copy)))
+		      (if (file-exists? name)
+			  (let ([back-name (mred:path-utils^:generate-backup-name name)])
+			    (unless (file-exists? back-name)
+				    (rename-file name back-name)))))
+		  #t)
+		#f))]
+
+	 [get-canvas
+	  (lambda ()
+	    (cond
+	     [(and active-canvas
+		   (member active-canvas canvases))
+	      active-canvas]
+	     [(null? canvases) #f]
+	     [else (car canvases)]))]
+	 [get-frame
+	  (lambda ()
+	    (let ([c (get-canvas)])
+	      (if c
+		  (let ([f (send c get-parent)])
+		    (if (null? f)
+			#f
+			f))
+		  #f)))])
+	(sequence
+	  (apply super-init args)))))
+
+  (define edits%
+    (class-asi wx:snip%
+      (private
+	[edits null])
+      (public
+	[add
+	 (lambda (edit)
+	   (unless (let loop ([e edits])
+		     (cond
+		       [(null? e) #f]
+		       [else (if (eq? this (car e))
+				 #t
+				 (loop (cdr e)))]))
+	    (set! edits (cons edit edits))))])))
+
+  (define edits (make-object edits%))
+
+  (define make-edit%
+    (lambda (super%)
+      (class (make-std-buffer% super%) args
+        (inherit mode canvases
+		 flash-on get-keymap get-start-position
+		 on-default-char on-default-event 
+		 set-file-format get-style-list)
+	(rename [super-on-focus on-focus]
+		[super-on-local-event on-local-event]
+		[super-on-local-char on-local-char]
+		[super-on-insert on-insert]
+		[super-on-delete on-delete]
+		[super-after-insert after-insert]
+		[super-after-delete after-delete])
+	(public
+	 [set-mode
+	  (lambda (m)
+	    (if mode
+		(send mode deinstall this))
+	    (if (is-a? m mred:mode^:mode%)
+		(begin
+		  (set! mode m)
+		  (set-file-format (ivar m file-format))
+		  (send (send (get-style-list) 
+			      find-named-style "Standard")
+			set-delta (ivar m standard-style-delta))
+		  (send m install this))
+		(begin
+		  (set! mode #f)
+		  (send (send (get-style-list) 
+			      find-named-style "Standard")
+			set-delta (make-object wx:style-delta%)))))]
+	 [on-focus
+	  (lambda (on?)
+	    (super-on-focus on?)
+	    (when mode
+		  (send mode on-focus this on?)))]
+	 [on-local-event
+	  (lambda (mouse)
+	    (if (or (not mode)
+		    (not (send mode on-event this mouse)))
+		(super-on-local-event mouse)))]
+	 [on-insert
+	  (lambda (start len)
+	    (if (or (not mode) (send mode on-insert this start len))
+		(super-on-insert start len)))]
+	 [on-delete
+	  (lambda (start len)
+	    (if (or (not mode) (send mode on-delete this start len))
+		(super-on-delete start len)))]
+	 
+	 [after-insert
+	  (lambda (start len)
+	    (if mode (send mode after-insert this start len))
+	    (super-after-insert start len))]
+	 [after-delete
+	  (lambda (start len)
+	    (if mode (send mode after-delete this start len))
+	    (super-after-delete start len))])
+    
+	(sequence
+	  (apply super-init args)
+	  (send edits add this)
+	  (let ([keymap (get-keymap)])
+	    (mred:keymap^:set-keymap-error-handler keymap)
+	    (mred:keymap^:set-keymap-implied-shifts keymap)
+	    (send keymap chain-to-keymap mred:keymap^:global-keymap #f))))))
+
+  (define edit% (make-edit% wx:media-edit%))
+
+  (define make-pasteboard% make-std-buffer%)
+  (define pasteboard% (make-pasteboard% wx:media-pasteboard%)))
+
+
diff --git a/collects/mred/exit.ss b/collects/mred/exit.ss
new file mode 100644
index 00000000..6c5234dd
--- /dev/null
+++ b/collects/mred/exit.ss
@@ -0,0 +1,36 @@
+;; [Robby]
+;; exit doesn't actually exit, now.
+
+(define-sigfunctor (mred:exit@ mred:exit^)
+  (import)
+  (rename (-exit exit))
+
+  (define exit-callbacks '())
+	 
+  (define insert-exit-callback
+    (lambda (f)
+      (set! exit-callbacks (cons f exit-callbacks))
+      f))
+
+  (define remove-exit-callback
+    (lambda (cb)
+      (set! exit-callbacks
+	    (let loop ([cb-list exit-callbacks])
+	      (cond
+	       [(null? cb-list) ()]
+	       [(eq? cb (car cb-list)) (cdr cb-list)]
+	       [else (cons (car cb-list) (loop (cdr cb-list)))])))))
+
+  (define -exit
+    (lambda ()
+      (set! exit-callbacks
+	    (let loop ([cb-list exit-callbacks])
+	      (cond
+	       [(null? cb-list) ()]
+	       [(not ((car cb-list))) cb-list]
+	       [else (loop (cdr cb-list))])))
+      (if (null? exit-callbacks)
+	  (begin (exit)
+		 #t)
+	  #f))))
+
diff --git a/collects/mred/finder.ss b/collects/mred/finder.ss
new file mode 100644
index 00000000..dc6216cd
--- /dev/null
+++ b/collects/mred/finder.ss
@@ -0,0 +1,432 @@
+(define-sigfunctor (mred:finder@ mred:finder^)
+  (import mzlib:string^ mzlib:function^ mzlib:file^)
+
+  (define filter-match?
+    (lambda (filter name msg)
+      (let-values ([(base name dir?) (split-path name)])
+		  (if (mzlib:string^:regexp-match-exact? filter name)
+		      #t
+		      (begin
+			(wx:message-box msg "Error")
+			#f)))))
+      
+  (define last-directory #f)
+  
+  (define make-relative
+    (lambda (s) s))
+  
+  (define current-find-file-directory
+    (opt-lambda ([dir 'get])
+		(cond
+		 [(eq? dir 'get)
+		  (if (not last-directory)
+		      (set! last-directory (current-directory)))
+		  last-directory]
+		 [(and (string? dir)
+		       (directory-exists? dir))
+		  (set! last-directory dir)
+		  #t]
+		 [else #f])))
+
+  (define finder-dialog%
+    (class wx:dialog-box% (save-mode? replace-ok? multi-mode? 
+				      result-box start-dir 
+				      start-name prompt 
+				      file-filter file-filter-msg)
+     (inherit
+      new-line tab fit center
+      show
+      popup-menu)
+     
+     (private
+      [WIDTH 500]
+      [HEIGHT 500]
+
+      dirs current-dir
+      last-selected
+      
+      [select-counter 0])
+     
+     (private
+      [set-directory
+       (lambda (dir) ; dir is normalied
+	 (set! current-dir dir)
+	 (set! last-directory dir)
+	 (let-values 
+	  ([(dir-list menu-list)
+	    (let loop ([this-dir dir]
+		       [dir-list ()]
+		       [menu-list ()])
+	      (let-values ([(base-dir in-dir dir?) (split-path this-dir)])
+			  (if (eq? wx:platform 'windows)
+			      (mzlib:string^:string-lowercase! in-dir))
+			  (let* ([dir-list (cons this-dir dir-list)]
+				 [menu-list (cons in-dir menu-list)])
+			    (if base-dir
+				(loop base-dir dir-list menu-list)
+				; No more
+				(values dir-list menu-list)))))])
+	  (set! dirs dir-list)
+	  
+	  (send dir-choice clear)
+	  (let loop ([choices menu-list])
+	    (unless (null? choices)
+		    (send dir-choice append (car choices))
+		    (loop (cdr choices))))
+	  (send dir-choice set-selection (sub1 (length dirs)))
+	  (send dir-choice set-size -1 -1 -1 -1))
+	 
+	 (send name-list clear)
+	 (send name-list set
+	       (mzlib:function^:quicksort
+		(let loop ([l (directory-list dir)])
+		  (if (null? l)
+		      '()
+		      (let ([s (car l)]
+			    [rest (loop (cdr l))])
+			(if (directory-exists? (build-path dir s))
+			    (cons
+			     (string-append s
+					    (case wx:platform
+					      (unix "/")
+					      (windows "\\")
+					      (macintosh ":")))
+			     rest)
+			    (if (or (not file-filter)
+				    (mzlib:string^:regexp-match-exact? file-filter s))
+				(cons s rest)
+				rest)))))
+		(if (eq? wx:platform 'unix) string<? string-ci<?)))
+	 (set! last-selected -1))])
+     
+     (public
+      [do-dir
+       (lambda (choice event)
+	 (let ([which (send event get-selection)])
+	   (if (< which (length dirs))
+	       (set-directory (list-ref dirs which)))))]
+      
+      [do-goto
+       (opt-lambda (button event [default ""])
+		   (let ([orig-dir (wx:get-text-from-user
+				    "Directory" "Go to Directory"
+				    default)])
+		     (if (string? orig-dir)
+			 (let ([dir (mzlib:file^:normalize-path orig-dir current-dir)])
+			   (if (directory-exists? dir)
+			       (set-directory dir)
+			       (begin
+				 (wx:message-box 
+				  (string-append "Bad directory: " dir)
+				  "Error")
+				 (do-goto button event orig-dir)))))))]
+      
+      [on-default-action
+       (lambda (which)
+	 (if (eq? which name-list)
+	     (let* ([which (send name-list get-string-selection)]
+		    [dir (build-path current-dir
+				     (make-relative which))])
+	       (if (directory-exists? dir)
+		   (set-directory (mzlib:file^:normalize-path dir))
+		   (if save-mode?
+		       (send name-field set-value which)
+		       (if multi-mode?
+			   (do-add)
+			   (do-ok)))))
+	     (if (eq? which name-field)
+		 (do-ok))))]
+      
+      [do-name
+       (lambda (text event)
+	 (if (eq? (send event get-event-type)
+		  wx:const-event-type-text-enter-command)
+	     (do-ok)))]
+      [do-name-list
+       (lambda args #f)]
+      [do-result-list
+       (lambda args #f)]
+      
+      [do-into-dir
+       (lambda args
+	 (let ([name (send name-list get-string-selection)])
+	   (if (string? name)
+	       (let ([name (build-path current-dir
+				       (make-relative name))])
+		 (if (directory-exists? name)
+		     (set-directory (mzlib:file^:normalize-path name)))))))]
+      
+      [do-ok
+       (lambda args
+	 (if multi-mode?
+	     (let loop ([n (sub1 select-counter)][result ()])
+	       (if (< n 0)
+		   (begin
+		     (set-box! result-box result)
+		     (show #f))
+		   (loop (sub1 n) 
+			 (cons (send result-list get-string n)
+			       result))))
+	     (let ([name
+		    (if save-mode?
+			(send name-field get-value)
+			(send name-list get-string-selection))])
+	       (cond
+		[(not (string? name)) 'nothing-selected]
+		[(string=? name "")
+		 (wx:message-box "You must specify a file name"
+				 "Error")]
+		[(and save-mode? 
+		      file-filter 
+		      (not (mzlib:string^:regexp-match-exact? file-filter name)))
+		 (wx:message-box file-filter-msg "Error")]
+		[else
+		 (let ([file (build-path current-dir
+					 (make-relative name))])
+		   (if (directory-exists? file)
+		       (if save-mode?
+			   (wx:message-box
+			    "That is the name of a directory."
+			    "Error")
+			   (set-directory (mzlib:file^:normalize-path file)))
+		       (if (or (not save-mode?)
+			       (not (file-exists? file))
+			       replace-ok?
+			       (= (wx:message-box
+				   (string-append
+				    "The file " 
+				    name 
+				    " already exists. "
+				    "Replace it?")
+				   "Warning"
+				   wx:const-yes-no)
+				  wx:const-yes))
+			   (begin
+			     (set-box! result-box (mzlib:file^:normalize-path file))
+			     (show #f)))))]))))]
+      
+      [add-one
+       (lambda (name)
+	 (unless (or (directory-exists? name)
+		     (> (send result-list find-string name) -1))
+		 (set! select-counter (add1 select-counter))
+		 (send result-list append (mzlib:file^:normalize-path name))))]
+      [do-add
+       (lambda args
+	 (let ([name (send name-list get-string-selection)])
+	   (if (string? name)
+	       (let ([name (build-path current-dir
+				       (make-relative name))])
+		 (add-one name)))))]
+      [do-add-all
+       (lambda args
+	 (let loop ([n 0])
+	   (let ([name (send name-list get-string n)])
+	     (if (and (string? name)
+		      (positive? (string-length name)))
+		 (let ([name (build-path current-dir
+					 (make-relative name))])
+		   (add-one name)
+		   (loop (add1 n)))))))]
+      [do-remove
+       (lambda args
+	 (let loop ([n 0])
+	   (if (< n select-counter)
+	       (if (send result-list selected? n)
+		   (begin
+		     (send result-list delete n)
+		     (set! select-counter (sub1 select-counter))
+		     (loop n))
+		   (loop (add1 n))))))]
+      
+      [do-cancel
+       (lambda args
+	 (set-box! result-box #f)
+	 (show #f))]
+
+      [on-close (lambda () #f)])
+     (sequence
+       
+       (super-init () (if save-mode? "Put File" "Get File") 
+		   #t 300 300 WIDTH HEIGHT)
+       
+       (make-object wx:message% this prompt)
+       
+       (new-line))
+
+     (private
+      [dir-choice (make-object wx:choice%
+			       this do-dir '() -1 -1 -1 -1
+			       '("XXXXXXXXXXXXXXXXXXXXXXXXXXX"))]
+      
+      [name-list (begin
+		   (new-line)
+		   (make-object wx:list-box%
+				this do-name-list
+				() wx:const-single
+				-1 -1
+				(if multi-mode? (* 1/2 WIDTH) WIDTH) 300
+				() wx:const-needed-sb))]
+      
+      [result-list
+       (if multi-mode?
+	   (make-object wx:list-box%
+			this do-result-list
+			() 
+			(if (eq? wx:window-system 'motif)
+			    wx:const-extended
+			    wx:const-multiple)
+			-1 -1
+			(* 1/2 WIDTH) 300
+			() wx:const-needed-sb))])
+     (sequence
+       (new-line))
+     
+     (private
+      [name-field
+       (if save-mode?
+	   (let ([v (make-object wx:text%
+				 this do-name
+				 "Name: " ""
+				 -1 -1
+				 400 -1
+				 wx:const-process-enter)])
+	     (if (string? start-name)
+		 (send v set-value start-name))
+	     (new-line)
+	     v))]
+      [into-dir-button
+       (if save-mode?
+	   (make-object wx:button%
+			this do-into-dir "Open Directory"))]
+      [goto-button (make-object wx:button%
+				this do-goto "Go to Directory...")]
+      [add-button (if multi-mode?
+		      (make-object wx:button%
+				   this do-add
+				   "Add"))]
+      [add-all-button (if multi-mode?
+			  (make-object wx:button%
+				       this do-add-all
+				       "Add All"))]
+      [remove-button (if multi-mode?
+			 (make-object wx:button%
+				      this do-remove
+				      "Remove"))])
+     (sequence
+       (if multi-mode?
+	   (tab 40)
+	   (tab 100)))
+     (private
+      [cancel-button (make-object wx:button%
+				  this do-cancel
+				  "Cancel")]
+      [ok-button
+       (let ([w (send cancel-button get-width)])
+	 (make-object wx:button%
+		      this do-ok
+		      "OK" -1 -1 w))])
+     (sequence
+       (fit)
+       
+       (cond
+	[(and start-dir
+	      (not (null? start-dir))
+	      (directory-exists? start-dir))
+	 (set-directory (mzlib:file^:normalize-path start-dir))]
+	[last-directory (set-directory last-directory)]
+	[else (set-directory (current-directory))])
+       
+       (center wx:const-both)
+       
+       (show #t))))
+
+  (define common-put-file
+    (opt-lambda ([name ()][directory ()][replace? #f]
+			  [prompt "Select File"][filter #f]
+			  [filter-msg  "That name does not have the right form"])
+		(let* ([directory (if (and (null? directory)
+					   (string? name))
+				      (mzlib:file^:path-only name)
+				      directory)]
+		       [name (if (string? name)
+				 (mzlib:file^:file-name-from-path name)
+				 name)]
+		       [v (box #f)])
+		  (make-object finder-dialog% #t replace? #f v 
+			       directory name prompt filter filter-msg)
+		  (unbox v))))
+
+  (define common-get-file
+    (opt-lambda ([directory ()][prompt "Select File"][filter #f]
+			       [filter-msg "Bad name"])
+		(let ([v (box #f)])
+		  (make-object finder-dialog% #f #f #f v directory '() prompt 
+			       filter filter-msg)
+		  (unbox v))))
+
+  (define common-get-file-list
+    (opt-lambda ([directory ()][prompt "Select Files"][filter #f]
+			       [filter-msg "Bad name"])
+		(let ([v (box ())])
+		  (make-object finder-dialog% #f #f #t v directory '() prompt 
+			       filter filter-msg)
+		  (unbox v))))
+
+  (define std-put-file
+    (opt-lambda ([name ()][directory ()][replace? #f][prompt "Select File"]
+			  [filter #f]
+			  [filter-msg 
+			   "That filename does not have the right form."])
+		(let* ([directory (if (and (null? directory)
+					   (string? name))
+				      (or (mzlib:file^:path-only name) null)
+				      directory)]
+		       [name (if (string? name)
+				 (mzlib:file^:file-name-from-path name)
+				 name)]
+		       [f (wx:file-selector prompt directory name
+					    '()
+					    (if (eq? wx:platform 'windows)
+						"*.*"
+						"*")
+					    wx:const-save)])
+		  (if (or (null? f) (and filter (not (filter-match? filter 
+								    f
+								    filter-msg))))
+		      #f
+		      (let* ([f (mzlib:file^:normalize-path f)]
+			     [dir (mzlib:file^:path-only f)]
+			     [name (mzlib:file^:file-name-from-path f)])
+			(cond
+			 [(not (and (string? dir) (directory-exists? dir)))
+			  (wx:message-box "Error" "That directory does not exist.")
+			  #f]
+			 [(equal? name "")
+			  (wx:message-box "Error" "Empty filename.")
+			  #f]
+			 [else f]))))))
+
+  (define std-get-file
+    (opt-lambda ([directory ()][prompt "Select File"][filter #f]
+			       [filter-msg 
+				"That filename does not have the right form."])
+		(let ([f (wx:file-selector prompt directory)])
+		  (if (null? f)
+		      #f
+		      (if (or (not filter) (filter-match? filter f filter-msg))
+			  (let ([f (mzlib:file^:normalize-path f)])
+			    (cond
+			     [(directory-exists? f)
+			      (wx:message-box "Error" 
+					      "That is a directory name.")
+			      #f]
+			     [(not (file-exists? f))
+			      (wx:message-box "That file does not exist.")
+			      #f]
+			     [else f]))
+			  #f)))))
+
+  ; By default, use platform-specific get/put
+  (define put-file std-put-file)
+  (define get-file std-get-file))
diff --git a/collects/mred/keys.ss b/collects/mred/keys.ss
new file mode 100644
index 00000000..187c05b6
--- /dev/null
+++ b/collects/mred/keys.ss
@@ -0,0 +1,746 @@
+(define-sigfunctor (mred:keymap@ mred:keymap^)
+  (import mred:finder^ mred:handler^ mred:find-string^ mred:scheme-paren^)
+
+  '(printf "mred:keymap@~n")
+
+  ; This is a list of keys that are typed with the SHIFT key, but
+  ;  are not normally thought of as shifted. It will have to be
+  ;  changed for different keyboards.
+  (define shifted-key-list
+    '("<" ">" "?" ":" "~" "\""
+	  "{" "}"
+	  "!" "@" "#" "$" "%" "^" "&" "*" "(" ")" "_" "+"
+	  "|"))
+
+  (define keyerr
+    (lambda (str)
+      (display str (current-error-port))))
+
+  (define (set-keymap-error-handler keymap)
+    (send keymap set-error-callback keyerr))
+
+  (define (set-keymap-implied-shifts keymap)
+    (map (lambda (k) (send keymap implies-shift k)) 
+	 shifted-key-list))
+
+  (define (make-meta-prefix-list key)
+    (list (string-append "m:" key)
+	  (string-append "c:[;" key)
+	  (string-append "ESC;" key)))
+
+  (define send-map-function-meta
+    (lambda (keymap key func)
+      (for-each (lambda (key)
+		  (send keymap map-function key func))
+		(make-meta-prefix-list key))))
+
+  ; This installs the standard keyboard mapping
+  (define setup-global-keymap
+    ; Define some useful keyboard functions
+    (let* ([ring-bell
+	    (lambda (edit event)
+	      (send (let loop ([p (send event get-event-object)])
+		      (let ([parent (send p get-parent)])
+			(if (null? parent)
+			    p
+			    (loop parent))))
+		    clear-mini-panel%)
+	      (wx:bell))]
+	   [save-file-as
+	    (lambda (edit event)
+	      (let ([file (mred:finder^:put-file)])
+		(if file
+		    (send edit save-file file)))
+	      #t)]
+	   [save-file
+	    (lambda (edit event)
+	      (if (null? (send edit get-filename))
+		  (save-file-as edit event)
+		  (send edit save-file))
+	      #t)]
+	   [load-file
+	    (lambda (edit event)
+	      (mred:handler^:open-file)
+	      #t)]
+	   [find-string
+	    (lambda (edit event . extras)
+	      (let ([x-box (box 0)]
+		    [y-box (box 0)]
+		    [canvas (send event get-event-object)])
+		(send event position x-box y-box)
+		(send canvas client-to-screen x-box y-box)
+		(mred:find-string^:find-string canvas ()
+					       (- (unbox x-box) 30)
+					       (- (unbox y-box) 30)
+					       (cons 'ignore-case extras))))]
+	   [find-string-reverse
+	    (lambda (edit event)
+	      (find-string edit event 'reverse))]
+	   [find-string-replace
+	    (lambda (edit event)
+	      (find-string edit event 'replace))]
+	   
+	   [toggle-anchor
+	    (lambda (edit event)
+	      (send edit set-anchor
+		    (not (send edit get-anchor))))]
+	   [flash-paren-match
+	    (lambda (edit event)
+	      (send edit on-default-char event)
+	      (let ([pos (mred:scheme-paren^:scheme-backward-match 
+			  edit
+			  (send edit get-start-position)
+			  0)])
+		(when pos
+		      (send edit flash-on pos (+ 1 pos))))
+	      #t)]
+	   [center-view-on-line
+	    (lambda (edit event)
+	      (let ([new-mid-line (send edit position-line
+					(send edit get-start-position))]
+		    [bt (box 0)]
+		    [bb (box 0)])
+		(send edit get-visible-line-range bt bb)
+		(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
+		       [top-pos (send edit line-start-position 
+				      (max (- new-mid-line half) 0))]
+		       [bottom-pos (send edit line-start-position 
+					 (min (+ new-mid-line half)
+					      (send edit position-line 
+						    (send edit last-position))))])
+		  (send edit scroll-to-position 
+			top-pos
+			#f
+			bottom-pos)))
+	      #t)]
+	   [collapse-variable-space
+	    (lambda (leave-one? edit event)
+	      (letrec ([find-nonwhite
+			(lambda (pos d)
+			  (let ([c (send edit get-character pos)])
+			    (cond
+			     [(char=? #\newline c) pos]
+			     [(char-whitespace? c) 
+			      (find-nonwhite (+ pos d) d)]
+			     [else pos])))])
+		(let ([sel-start (send edit get-start-position)]
+		      [sel-end (send edit get-end-position)])
+		  (if (= sel-start sel-end)
+		      (let ([start (+ (find-nonwhite (- sel-start 1) -1)
+				      (if leave-one? 2 1))]
+			    [end (find-nonwhite sel-start 1)])
+			(if (< start end)
+			    (begin
+			      (send edit begin-edit-sequence)
+			      (send edit delete start end)
+			      (if (and leave-one?
+				       (not (char=? #\space
+						    (send edit get-character
+							  (sub1 start)))))
+				  (send edit insert " " (sub1 start) start))
+			      (send edit set-position start)
+			      (send edit end-edit-sequence))
+			    (if leave-one?
+				(let ([at-start
+				       (send edit get-character sel-start)]
+				      [after-start
+				       (send edit get-character 
+					     (sub1 sel-start))])
+				  (cond
+				   [(char-whitespace? at-start)
+				    (if (not (char=? at-start #\space))
+					(send edit insert " " sel-start 
+					      (add1 sel-start)))
+				    (send edit set-position (add1 sel-start))]
+				   [(char-whitespace? after-start)
+				    (if (not (char=? after-start #\space))
+					(send edit insert " " (sub1 sel-start)
+					      sel-start))]
+				   [else (send edit insert " ")])))))))))]
+
+	   [collapse-space
+	    (lambda (edit event)
+	      (collapse-variable-space #t edit event))]
+
+	   [remove-space
+	    (lambda (edit event)
+	      (collapse-variable-space #f edit event))]
+
+	   [collapse-newline
+	    (lambda (edit event)
+	      (letrec ([find-nonwhite
+			(lambda (pos d offset)
+			  (catch
+			   escape
+			   (let ([max (if (> offset 0)
+					  (send edit last-position)
+					  -1)])
+			     (let loop ([pos pos])
+			       (if (= pos max)
+				   (escape pos)
+				   (let ([c (send edit get-character 
+						  (+ pos offset))])
+				     (cond
+				      [(char=? #\newline c)
+				       (loop (+ pos d))
+				       (escape pos)]
+				      [(char-whitespace? c) 
+				       (loop (+ pos d))]
+				      [else pos])))))))])
+		(let ([sel-start (send edit get-start-position)]
+		      [sel-end (send edit get-end-position)])
+		  (if (= sel-start sel-end)
+		      (let* ([pos-line
+			      (send edit position-line sel-start #f)]
+			     [pos-line-start
+			      (send edit line-start-position pos-line)]
+			     [pos-line-end
+			      (send edit line-end-position pos-line)]
+
+			     [whiteline?
+			      (let loop ([pos pos-line-start])
+				(if (>= pos pos-line-end)
+				    #t
+				    (and (char-whitespace?
+					  (send edit get-character pos))
+					 (loop (add1 pos)))))]
+			     
+			     [start (find-nonwhite pos-line-start -1 -1)]
+			     [end (find-nonwhite pos-line-end 1 0)]
+
+			     [start-line 
+			      (send edit position-line start #f)]
+			     [start-line-start
+			      (send edit line-start-position start-line)]
+			     [end-line
+			      (send edit position-line end #f)]
+			     [end-line-start
+			      (send edit line-start-position (add1 end-line))])
+			(cond
+			 [(and whiteline?
+			       (= start-line pos-line)
+			       (= end-line pos-line))
+			  ; Special case: just delete this line
+			  (send edit delete pos-line-start (add1 pos-line-end))]
+			 [(and whiteline? (< start-line pos-line))
+			  ; Can delete before & after
+			  (send* edit 
+				 (begin-edit-sequence)
+				 (delete (add1 pos-line-end) end-line-start)
+				 (delete start-line-start pos-line-start)
+				 (end-edit-sequence))]
+			 [else
+			  ; Only delete after
+			  (send edit delete (add1 pos-line-end) 
+				end-line-start)]))))))]
+
+	   [open-line
+	    (lambda (edit event)
+	      (let ([sel-start (send edit get-start-position)]
+		    [sel-end (send edit get-end-position)])
+		(if (= sel-start sel-end)
+		    (send* edit 
+			   (insert #\newline)
+			   (set-position sel-start)))))]
+
+	   [transpose-chars
+	    (lambda (edit event)
+	      (let ([sel-start (send edit get-start-position)]
+		    [sel-end (send edit get-end-position)])
+		(when (= sel-start sel-end)
+		      (let ([sel-start
+			     (if (= sel-start
+				    (send edit line-end-position
+					  (send edit position-line sel-start)))
+				 (sub1 sel-start)
+				 sel-start)])
+			(let ([s (send edit get-text
+				       sel-start (add1 sel-start))])
+			  (send* edit
+				 (begin-edit-sequence)
+				 (delete sel-start (add1 sel-start))
+				 (insert s (- sel-start 1))
+				 (set-position (add1 sel-start))
+				 (end-edit-sequence)))))))]
+
+	   [transpose-words
+	    (lambda (edit event)
+	      (let ([sel-start (send edit get-start-position)]
+		    [sel-end (send edit get-end-position)])
+		(when (= sel-start sel-end)
+		      (let ([word-1-start (box sel-start)])
+			(send edit find-wordbreak word-1-start ()
+			      wx:const-break-for-caret)
+			(let ([word-1-end (box (unbox word-1-start))])
+			  (send edit find-wordbreak () word-1-end
+				wx:const-break-for-caret)
+			  (let ([word-2-end (box (unbox word-1-end))])
+			    (send edit find-wordbreak () word-2-end
+				  wx:const-break-for-caret)
+			    (let ([word-2-start (box (unbox word-2-end))])
+			      (send edit find-wordbreak word-2-start ()
+				    wx:const-break-for-caret)
+			      (let ([text-1 (send edit get-text
+						  (unbox word-1-start)
+						  (unbox word-1-end))]
+				    [text-2 (send edit get-text
+						  (unbox word-2-start)
+						  (unbox word-2-end))])
+				(send* edit
+				       (begin-edit-sequence)
+				       (insert text-1 
+					       (unbox word-2-start)
+					       (unbox word-2-end))
+				       (insert text-2 
+					       (unbox word-1-start)
+					       (unbox word-1-end))
+				       (set-position (unbox word-2-end))
+				       (end-edit-sequence))))))))))]
+
+	   [capitalize-it
+	    (lambda (edit all? char-case char-case2)
+	      (let ([sel-start (send edit get-start-position)]
+		    [sel-end (send edit get-end-position)]
+		    [real-end (send edit last-position)])
+		(when (= sel-start sel-end)
+		      (let ([end-box (box sel-start)])
+			(send edit find-wordbreak () end-box 
+			      wx:const-break-for-caret)
+			(dynamic-wind
+			 (lambda ()
+			   (send edit begin-edit-sequence))
+			 (lambda ()
+			   (let loop ([pos sel-start][char-case char-case])
+			     (if (< pos real-end)
+				 (let ([c (send edit get-character pos)])
+				   (if (char-alphabetic? c)
+				       (begin
+					 (send edit insert 
+					       (list->string
+						(list (char-case c)))
+					       pos (add1 pos))
+					 (if (and all? (< (add1 pos) 
+							  (unbox end-box)))
+					     (loop (add1 pos) char-case2)))
+				       (loop (add1 pos) char-case))))))
+			 (lambda ()
+			   (send edit end-edit-sequence)))
+			(send edit set-position (unbox end-box))))))]
+
+	   [capitalize-word
+	    (lambda (edit event)
+	      (capitalize-it edit #t char-upcase char-downcase))]
+	   [upcase-word
+	    (lambda (edit event)
+	      (capitalize-it edit #t char-upcase char-upcase))]
+	   [downcase-word
+	    (lambda (edit event)
+	      (capitalize-it edit #t char-downcase char-downcase))]
+
+	   [kill-word
+	    (lambda (edit event)
+	      (let ([sel-start (send edit get-start-position)]
+		    [sel-end (send edit get-end-position)])
+		(let ([end-box (box sel-end)])
+		  (send edit find-wordbreak () end-box 
+			wx:const-break-for-caret)
+		  (send edit kill 0 sel-start (unbox end-box)))))]
+
+	   [backward-kill-word
+	    (lambda (edit event)
+	      (let ([sel-start (send edit get-start-position)]
+		    [sel-end (send edit get-end-position)])
+		(let ([start-box (box sel-start)])
+		  (send edit find-wordbreak start-box ()
+			wx:const-break-for-caret)
+		  (send edit kill 0 (unbox start-box) sel-end))))]
+
+	   [region-click
+	    (lambda (edit event f)
+	      (when (send event button-down?)
+		    (let ([x-box (box (send event get-x))]
+			  [y-box (box (send event get-y))]
+			  [eol-box (box #f)])
+		      (send edit global-to-local x-box y-box)
+		      (let ([click-pos (send edit find-position 
+					     (unbox x-box)
+					     (unbox y-box)
+					     eol-box)]
+			    [start-pos (send edit get-start-position)]
+			    [end-pos (send edit get-end-position)])
+			(let ([eol (unbox eol-box)])
+			  (if (< start-pos click-pos)
+			      (f click-pos eol start-pos click-pos)
+			      (f click-pos eol click-pos end-pos)))))))]
+	   [copy-click-region
+	    (lambda (edit event)
+	      (region-click edit event
+			    (lambda (click eol start end)
+			      (send edit flash-on start end)
+			      (send edit copy #f 0 start end))))]
+	   [cut-click-region
+	    (lambda (edit event)
+	      (region-click edit event
+			    (lambda (click eol start end)
+			      (send edit cut #f 0 start end))))]
+	   [paste-click-region
+	    (lambda (edit event)
+	      (region-click edit event
+			    (lambda (click eol start end)
+			      (send edit set-position click)
+			      (send edit paste 0 click))))]
+
+	   [mouse-copy-clipboard
+	    (lambda (edit event)
+	      (send edit copy #f (send event get-time-stamp)))]
+
+	   [mouse-paste-clipboard
+	    (lambda (edit event)
+	      (send edit paste (send event get-time-stamp)))]
+
+	   [mouse-cut-clipboard
+	    (lambda (edit event)
+	      (send edit cut #f (send event get-time-stamp)))]
+
+	   [select-click-word
+	    (lambda (edit event)
+	      (region-click edit event
+			    (lambda (click eol start end)
+			      (let ([start-box (box click)]
+				    [end-box (box click)])
+				(send edit find-wordbreak 
+				      start-box
+				      end-box
+				      wx:const-break-for-selection)
+				(send edit set-position
+				      (unbox start-box)
+				      (unbox end-box))))))]
+	   [select-click-line
+	    (lambda (edit event)
+	      (region-click edit event
+			    (lambda (click eol start end)
+			      (let* ([line (send edit position-line 
+						 click eol)]
+				     [start (send edit line-start-position
+						  line #f)]
+				     [end (send edit line-end-position
+						line #f)])
+				(send edit set-position start end)))))]
+
+	   [goto-line
+	    (lambda (edit event)
+	      (let ([num-str (wx:get-text-from-user "Goto Line:" "Goto Line")])
+		(if (string? num-str)
+		    (let ([line-num (string->number num-str)])
+		      (if line-num
+			  (let ([pos (send edit line-start-position 
+					   (sub1 line-num))])
+			    (send edit set-position pos))))))
+	      #t)]
+	   [goto-position
+	    (lambda (edit event)
+	      (let ([num-str (wx:get-text-from-user "Goto Position:" 
+						    "Goto Position")])
+		(if (string? num-str)
+		    (let ([pos (string->number num-str)])
+		      (if pos
+			  (send edit set-position (sub1 pos))))))
+	      #t)]
+	   [repeater
+	    (lambda (n edit)
+	      (let* ([km (send edit get-keymap)]
+		     [done
+		      (lambda ()
+			(send km set-break-sequence-callback void)
+			(send km remove-grab-key-function))])
+		(send km set-grab-key-function
+		      (lambda (name local-km edit event)
+			(if (null? name)
+			    (let ([k (send event get-key-code)])
+			      (if (<= (char->integer #\0) k (char->integer #\9))
+				  (set! n (+ (* n 10) (- k (char->integer #\0))))
+				  (begin
+				    (done)
+				    (dynamic-wind
+				     (lambda ()
+				       (send edit begin-edit-sequence))
+				     (lambda ()
+				       (let loop ([n n])
+					 (unless (zero? n)
+						 (send edit on-char event)
+						 (loop (sub1 n)))))
+				     (lambda ()
+				       (send edit end-edit-sequence))))))
+			    (begin
+			      (done)
+			      (dynamic-wind
+			       (lambda ()
+				 (send edit begin-edit-sequence))
+			       (lambda ()
+				 (let loop ([n n])
+				   (unless (zero? n)
+					   (send local-km call-function name edit event)
+					   (loop (sub1 n)))))
+			       (lambda ()
+				 (send edit end-edit-sequence)))))			       
+			#t))
+		(send km set-break-sequence-callback done)
+		#t))]
+	   [make-make-repeater
+	    (lambda (n)
+	      (lambda (edit event)
+		(repeater n edit)))]
+	   [current-macro '()] 
+	   [building-macro #f] [build-macro-km #f] [build-protect? #f]
+	   [do-macro
+	    (lambda (edit event)
+	      ; If c:x;e during record, copy the old macro
+	      (when building-macro
+		    (set! building-macro (append (reverse current-macro) 
+						 (cdr building-macro))))
+	      (let ([bm building-macro]
+		    [km (send edit get-keymap)])
+		(dynamic-wind
+		 (lambda ()
+		   (set! building-macro #f)
+		   (send edit begin-edit-sequence))
+		 (lambda ()
+		   (let/ec escape
+		     (for-each
+		      (lambda (f)
+			(let ([name (car f)]
+			      [event (cdr f)])
+			  (if (null? name)
+			      (send edit on-char event)
+			      (if (not (send km call-function 
+					     name edit event #t))
+				  (escape #t)))))
+		      current-macro)))
+		 (lambda ()
+		   (send edit end-edit-sequence)
+		   (set! building-macro bm))))
+	      #t)]
+	   [start-macro
+	    (lambda (edit event)
+	      (if building-macro
+		  (send build-macro-km break-sequence)
+		  (letrec* ([km (send edit get-keymap)]
+			    [done
+			     (lambda ()
+			       (if build-protect?
+				   (send km set-break-sequence-callback done)
+				   (begin
+				     (set! building-macro #f)
+				     (send km set-break-sequence-callback void)
+				     (send km remove-grab-key-function))))])
+		    (set! building-macro '())
+		    (set! build-macro-km km)
+		    (send km set-grab-key-function
+			  (lambda (name local-km edit event)
+			    (dynamic-wind
+			     (lambda ()
+			       (set! build-protect? #t))
+			     (lambda ()
+			       (if (null? name)
+				   (send edit on-default-char event)
+				   (send local-km call-function name edit event)))
+			     (lambda ()
+			       (set! build-protect? #f)))
+			    (when building-macro
+				  (set! building-macro 
+					(cons (cons name 
+						    (duplicate-key-event event))
+					      building-macro)))
+			    #t))
+		    (send km set-break-sequence-callback done)))
+	      #t)]
+	   [end-macro
+	    (lambda (edit event)
+	      (when building-macro
+		    (set! current-macro (reverse building-macro))
+		    (set! build-protect? #f)		    
+		    (send build-macro-km break-sequence))
+	      #t)])
+      (lambda (kmap)
+	; Redirect keymappng error messages to stderr
+	(send kmap set-error-callback keyerr)
+	; Set the implied shifting map
+	(map (lambda (k) (send kmap implies-shift k)) shifted-key-list)
+	(let* ([map (lambda (key func) 
+		      (send kmap map-function key func))]
+	       [map-meta (lambda (key func)
+			   (send-map-function-meta kmap key func))]
+	       [add (lambda (name func)
+		      (send kmap add-key-function name func))]
+	       [add-m (lambda (name func)
+			(send kmap add-mouse-function name func))])
+	
+	; Standards
+	(wx:add-media-buffer-functions kmap)
+	(wx:add-media-editor-functions kmap)
+	(wx:add-media-pasteboard-functions kmap)
+
+	; Map names to keyboard functions
+	(add "ring-bell" ring-bell)
+
+	(add "save-file" save-file)
+	(add "save-file-as" save-file-as)
+	(add "load-file" load-file)
+
+	(add "find-string" find-string)
+	(add "find-string-reverse" find-string-reverse)
+	(add "find-string-replace" find-string-replace)
+
+	(add "flash-paren-match" flash-paren-match)
+
+	(add "toggle-anchor" toggle-anchor)
+	(add "center-view-on-line" center-view-on-line)
+	(add "collapse-space" collapse-space)
+	(add "remove-space" remove-space)
+	(add "collapse-newline" collapse-newline)
+	(add "open-line" open-line)
+	(add "transpose-chars" transpose-chars)
+	(add "transpose-words" transpose-words)
+	(add "capitalize-word" capitalize-word)
+	(add "upcase-word" upcase-word)
+	(add "downcase-word" downcase-word)
+	(add "kill-word" kill-word)
+	(add "backward-kill-word" backward-kill-word)
+
+	(let loop ([n 9])
+	  (unless (negative? n)
+		  (let ([s (number->string n)])
+		    (add (string-append "command-repeat-" s)
+			 (make-make-repeater n))
+		    (loop (sub1 n)))))
+
+	(add "do-saved-macro" do-macro)
+	(add "start-macro-record" start-macro)
+	(add "end-macro-record" end-macro)
+
+	(add-m "copy-clipboard" mouse-copy-clipboard)
+	(add-m "cut-clipboard" mouse-cut-clipboard)
+	(add-m "paste-clipboard" mouse-paste-clipboard)
+	(add-m "copy-click-region" copy-click-region)
+	(add-m "cut-click-region" cut-click-region)
+	(add-m "paste-click-region" paste-click-region)
+	(add-m "select-click-word" select-click-word)
+	(add-m "select-click-line" select-click-line)
+
+	(add "goto-line" goto-line)
+	(add "goto-position" goto-position)
+
+	; Map keys to functions
+	(map "c:g" "ring-bell")
+	(map-meta "c:g" "ring-bell")
+	(map "c:x;c:g" "ring-bell")
+	(map "c:c;c:g" "ring-bell")
+
+	(map ")" "flash-paren-match")
+	(map "]" "flash-paren-match")
+	(map "}" "flash-paren-match")
+	(map "\"" "flash-paren-match")
+	
+	(map "c:p" "previous-line")
+	(map "c:n" "next-line")
+	(map "c:e" "end-of-line")
+	(map "d:RIGHT" "end-of-line")
+	(map "d:s:RIGHT" "select-to-end-of-line")
+	(map "m:RIGHT" "end-of-line")
+	(map "m:s:RIGHT" "select-to-end-of-line")
+	(map "c:a" "beginning-of-line")
+	(map "d:LEFT" "beginning-of-line")
+	(map "d:s:LEFT" "select-to-beginning-of-line")
+	(map "m:LEFT" "beginning-of-line")
+	(map "m:s:LEFT" "select-to-beginning-of-line")
+	(map "END" "end-of-line")
+	(map "HOME" "beginning-of-line")
+	
+	(map "c:h" "delete-previous-character")
+	(map "c:d" "delete-next-character")
+
+	(map "c:f" "forward-character")
+	(map "c:b" "backward-character")
+
+	(map-meta "f" "forward-word")
+	(map "a:RIGHT" "forward-word")
+	(map "a:s:RIGHT" "forward-select-word")
+	(map-meta "b" "backward-word")
+	(map "a:LEFT" "backward-word")
+	(map "a:s:LEFT" "backward-select-word")
+	(map-meta "d" "kill-word")
+	(map-meta "del" "backward-kill-word")
+	(map-meta "c" "capitalize-word")
+	(map-meta "u" "upcase-word")
+	(map-meta "l" "downcase-word")
+
+	(map-meta "<" "beginning-of-file")
+	(map "d:UP" "beginning-of-file")
+	(map-meta ">" "end-of-file")
+	(map "d:DOWN" "end-of-file")
+
+	(map "c:v" "next-page")
+	(map "a:DOWN" "next-page")
+	(map-meta "v" "previous-page")
+	(map "a:up" "previous-page")
+	(map "c:l" "center-view-on-line")
+	
+	(map "c:k" "delete-to-end-of-line")
+	(map "c:y" "paste-clipboard")
+	(map-meta "y" "paste-next")
+	(map "a:v" "paste-clipboard")
+	(map "d:v" "paste-clipboard")
+	(map "c:_" "undo")
+	(map "c:+" "redo")
+	(map "a:z" "undo")
+	(map "d:z" "undo")
+	(map "c:x;u" "undo")
+	(map "c:w" "cut-clipboard")
+	(map "a:x" "cut-clipboard")
+	(map "d:x" "cut-clipboard")
+	(map-meta "w" "copy-clipboard")
+	(map "a:c" "copy-clipboard")
+	(map "d:c" "copy-clipboard")
+
+	(map "c:x;c:s" "save-file")
+	(map "d:s" "save-file")
+	(map "c:x;c:w" "save-file-as")
+	(map "c:x;c:f" "load-file")
+
+	(map "c:s" "find-string")
+	(map "c:r" "find-string-reverse")
+	(map-meta "%" "find-string-replace")
+
+	(map-meta "space" "collapse-space")
+	(map-meta "\\" "remove-space")
+	(map "c:x;c:o" "collapse-newline")
+	(map "c:o" "open-line")
+	(map "c:t" "transpose-chars")
+	(map-meta "t" "transpose-words")
+
+	(map "c:space" "toggle-anchor")
+
+	(map-meta "g" "goto-line")
+	(map-meta "p" "goto-position")
+
+	(map "c:u" "command-repeat-0")
+	(let loop ([n 9])
+	  (unless (negative? n)
+		  (let ([s (number->string n)])
+		    (map-meta s (string-append "command-repeat-" s))
+		    (loop (sub1 n)))))
+
+	(map "c:x;e" "do-saved-macro")
+	(map "c:x;(" "start-macro-record")
+	(map "c:x;)" "end-macro-record")
+
+	(map "leftbuttontriple" "select-click-line")
+	(map "leftbuttondouble" "select-click-word")
+
+	(map "rightbutton" "copy-click-region")
+	(map "rightbuttondouble" "cut-click-region")
+	(map "middlebutton" "paste-click-region")
+	(map "c:rightbutton" "copy-clipboard")))))
+
+  (define global-keymap (make-object wx:keymap%))
+  (setup-global-keymap global-keymap))
\ No newline at end of file