(load "term/internal" nil t)
(defvar msdos-color-aliases
'(("snow" . "white")
("ghost white" . "white")
("ghostwhite" . "white")
("white smoke" . "white")
("whitesmoke" . "white")
("gainsboro" . "white")
("floral white" . "white")
("floralwhite" . "white")
("old lace" . "white")
("oldlace" . "white")
("linen" . "white")
("antique white" . "white")
("antiquewhite" . "white")
("papaya whip" . "white")
("papayawhip" . "white")
("blanched almond" . "white")
("blanchedalmond" . "white")
("bisque" . "white")
("peach puff" . "lightred")
("peachpuff" . "lightred")
("navajo white" . "lightred")
("navajowhite" . "lightred")
("moccasin" . "lightred")
("cornsilk" . "white")
("ivory" . "white")
("lemon chiffon" . "yellow")
("lemonchiffon" . "yellow")
("seashell" . "white")
("honeydew" . "white")
("mint cream" . "white")
("mintcream" . "white")
("azure" . "lightcyan")
("alice blue" . "lightcyan")
("aliceblue" . "lightcyan")
("lavender" . "lightcyan")
("lavender blush" . "lightcyan")
("lavenderblush" . "lightcyan")
("misty rose" . "lightred")
("mistyrose" . "lightred")
("aquamarine" . "blue")
("cadet blue" . "blue")
("cadetblue" . "blue")
("cornflower blue" . "lightblue")
("cornflowerblue" . "lightblue")
("midnight blue" . "blue")
("midnightblue" . "blue")
("navy blue" . "cyan")
("navyblue" . "cyan")
("navy" . "cyan")
("royalblue" . "blue")
("royal blue" . "blue")
("sky blue" . "lightblue")
("skyblue" . "lightblue")
("dodger blue" . "blue")
("dodgerblue" . "blue")
("powder blue" . "lightblue")
("powderblue" . "lightblue")
("slate blue" . "cyan")
("slateblue" . "cyan")
("steel blue" . "blue")
("steelblue" . "blue")
("coral" . "lightred")
("tomato" . "lightred")
("firebrick" . "red")
("gold" . "yellow")
("goldenrod" . "yellow")
("goldenrod yellow" . "yellow")
("goldenrodyellow" . "yellow")
("pale goldenrod" . "yellow")
("palegoldenrod" . "yellow")
("olive green" . "lightgreen")
("olivegreen" . "lightgreen")
("olive drab" . "green")
("olivedrab" . "green")
("forest green" . "green")
("forestgreen" . "green")
("lime green" . "lightgreen")
("limegreen" . "lightgreen")
("sea green" . "lightcyan")
("seagreen" . "lightcyan")
("spring green" . "green")
("springgreen" . "green")
("lawn green" . "lightgreen")
("lawngreen" . "lightgreen")
("chartreuse" . "yellow")
("yellow green" . "lightgreen")
("yellowgreen" . "lightgreen")
("green yellow" . "lightgreen")
("greenyellow" . "lightgreen")
("slate grey" . "lightgray")
("slategrey" . "lightgray")
("slate gray" . "lightgray")
("slategray" . "lightgray")
("dim grey" . "darkgray")
("dimgrey" . "darkgray")
("dim gray" . "darkgray")
("dimgray" . "darkgray")
("light grey" . "lightgray")
("lightgrey" . "lightgray")
("light gray" . "lightgray")
("gray" . "darkgray")
("grey" . "darkgray")
("khaki" . "green")
("maroon" . "red")
("orange" . "brown")
("orchid" . "brown")
("saddle brown" . "red")
("saddlebrown" . "red")
("peru" . "red")
("burlywood" . "brown")
("sandy brown" . "brown")
("sandybrown" . "brown")
("pink" . "lightred")
("hotpink" . "lightred")
("hot pink" ."lightred")
("plum" . "magenta")
("indian red" . "red")
("indianred" . "red")
("violet red" . "magenta")
("violetred" . "magenta")
("orange red" . "red")
("orangered" . "red")
("salmon" . "lightred")
("sienna" . "lightred")
("tan" . "lightred")
("chocolate" . "brown")
("thistle" . "magenta")
("turquoise" . "lightgreen")
("pale turquoise" . "cyan")
("paleturquoise" . "cyan")
("violet" . "magenta")
("blue violet" . "lightmagenta")
("blueviolet" . "lightmagenta")
("wheat" . "white")
("green yellow" . "yellow")
("greenyellow" . "yellow")
("purple" . "magenta")
("rosybrown" . "brown")
("rosy brown" . "brown")
("beige" . "brown"))
"List of alternate names for colors.")
(defun msdos-color-translate (name)
"Translate color specification in NAME into something DOS terminal groks."
(setq name (downcase name))
(let* ((len (length name))
(val (- (length x-colors)
(length (member name x-colors))))
(try))
(if (or (< val 0) (>= val (length x-colors))) (setq val nil))
(or val
(and (setq try (cdr (assoc name msdos-color-aliases)))
(msdos-color-translate try))
(and (> len 5)
(string= "light" (substring name 0 5))
(setq try (msdos-color-translate (substring name 5)))
(logior try 8))
(and (> len 6)
(string= "light " (substring name 0 6))
(setq try (msdos-color-translate (substring name 6)))
(logior try 8))
(and (> len 4)
(string= "pale" (substring name 0 4))
(setq try (msdos-color-translate (substring name 4)))
(logior try 8))
(and (> len 5)
(string= "pale " (substring name 0 5))
(setq try (msdos-color-translate (substring name 5)))
(logior try 8))
(and (> len 6)
(string= "medium" (substring name 0 6))
(msdos-color-translate (substring name 6)))
(and (> len 7)
(string= "medium " (substring name 0 7))
(msdos-color-translate (substring name 7)))
(and (> len 4)
(or (string= "dark" (substring name 0 4))
(string= "deep" (substring name 0 4)))
(msdos-color-translate (substring name 4)))
(and (> len 5)
(or (string= "dark " (substring name 0 5))
(string= "deep " (substring name 0 5)))
(msdos-color-translate (substring name 5)))
(and (> len 4) (save-match-data
(and
(string-match "gr[ae]y[0-9]" name)
(string-match "[0-9]+\\'" name)
(let ((num (string-to-int
(substring name (match-beginning 0)))))
(msdos-color-translate
(cond
((> num 90) "white")
((> num 50) "lightgray")
((> num 10) "darkgray")
(t "black")))))))
(and (> len 1) (save-match-data
(and
(string-match "[1-4]\\'" name)
(msdos-color-translate
(substring name 0 (match-beginning 0))))))
(and (= len 7) (eq (aref name 0) ?#)
(member (aref name 1)
'(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
?A ?B ?C ?D ?E ?F ?a ?b ?c ?d ?e ?f))
(msdos-color-translate
(msdos-approximate-color (string-to-number
(substring name 1) 16)))))))
(defun msdos-approximate-color (num)
"Return a DOS color name which is the best approximation for the number NUM."
(let ((color-values msdos-color-values)
(candidate (car msdos-color-values))
(best-distance 16777216) best-color)
(while candidate
(let* ((values (cdr candidate))
(value (+ (lsh (car values) 16)
(lsh (car (cdr values)) 8)
(nth 2 values))))
(if (< (abs (- value num)) best-distance)
(setq best-distance (abs (- value num))
best-color (car candidate))))
(setq color-values (cdr color-values))
(setq candidate (car color-values)))
best-color))
(defvar default-frame-alist nil)
(modify-frame-parameters terminal-frame default-frame-alist)
(defun msdos-bg-mode (&optional frame)
(let* ((frame (or frame (selected-frame)))
(params (frame-parameters frame))
(bg (cdr (assq 'background-color params))))
(if (member bg
'("black" "blue" "green" "red" "magenta" "brown" "darkgray"))
'dark
'light)))
(defun msdos-face-setup ()
(modify-frame-parameters terminal-frame default-frame-alist)
(modify-frame-parameters terminal-frame
(list (cons 'background-mode
(msdos-bg-mode terminal-frame))
(cons 'display-type 'color)))
(face-set-after-frame-default terminal-frame)
(set-face-foreground 'bold "yellow" terminal-frame)
(set-face-foreground 'italic "red" terminal-frame)
(set-face-foreground 'bold-italic "lightred" terminal-frame)
(set-face-foreground 'underline "white" terminal-frame)
(make-face 'msdos-menu-active-face)
(make-face 'msdos-menu-passive-face)
(make-face 'msdos-menu-select-face)
(set-face-foreground 'msdos-menu-active-face "white" terminal-frame)
(set-face-foreground 'msdos-menu-passive-face "lightgray" terminal-frame)
(set-face-background 'msdos-menu-active-face "blue" terminal-frame)
(set-face-background 'msdos-menu-passive-face "blue" terminal-frame)
(set-face-background 'msdos-menu-select-face "red" terminal-frame))
(add-hook 'before-init-hook 'msdos-face-setup)
(defun make-msdos-frame (&optional parameters)
(let* ((parms
(append initial-frame-alist default-frame-alist parameters nil))
(frame (make-terminal-frame parms)))
(modify-frame-parameters frame
(list (cons 'background-mode
(msdos-bg-mode frame))
(cons 'display-type 'color)))
frame))
(setq frame-creation-function 'make-msdos-frame)
(defun x-display-color-p (&optional display) 't)
(defun x-list-fonts (pattern &optional face frame maximum width)
(if (and (numberp width) (= width 1))
(list "default")
(list "no-such-font")))
(defun x-color-defined-p (color) (numberp (msdos-color-translate color)))
(defun x-display-pixel-width (&optional frame) (frame-width frame))
(defun x-display-pixel-height (&optional frame) (frame-height frame))
(defun x-display-planes (&optional frame) 4) (defun x-display-color-cells (&optional frame) 16) (defun x-server-max-request-size (&optional frame) 1000000) (defun x-server-vendor (&optional frame) t "GNU")
(defun x-server-version (&optional frame) '(1 0 0))
(defun x-display-screens (&optional frame) 1)
(defun x-display-mm-height (&optional frame) 200) (defun x-display-mm-width (&optional frame) 253) (defun x-display-backing-store (&optional frame) 'not-useful)
(defun x-display-visual-class (&optional frame) 'static-color)
(fset 'x-display-save-under 'ignore)
(fset 'x-get-resource 'ignore)
(defvar msdos-color-values
'(("black" 0 0 0)
("blue" 0 0 255)
("green" 0 255 0)
("cyan" 0 255 255)
("red" 255 0 0)
("magenta" 139 0 139) ("brown" 165 42 42)
("lightgray" 211 211 211)
("darkgray" 102 102 102) ("lightblue" 173 216 230)
("lightgreen" 144 238 144)
("lightcyan" 224 255 255)
("lightred" 255 52 179) ("lightmagenta" 238 0 238) ("yellow" 255 255 0)
("white" 255 255 255))
"A list of MS-DOS console colors and their RGB values.")
(defun x-color-values (color &optional frame)
"Return a description of the color named COLOR on frame FRAME.\n\
The value is a list of integer RGB values--(RED GREEN BLUE).\n\
These values range from 0 to 255; white is (255 255 255).\n\
If FRAME is omitted or nil, use the selected frame."
(if (x-color-defined-p color)
(let ((frame (or frame (selected-frame)))
(color-code (msdos-color-translate color)))
(cdr (nth color-code msdos-color-values)))))
(setq x-display-name "pc")
(setq split-window-keep-point t)
(defvar x-colors '("black"
"blue"
"green"
"cyan"
"red"
"magenta"
"brown"
"lightgray"
"darkgray"
"lightblue"
"lightgreen"
"lightcyan"
"lightred"
"lightmagenta"
"yellow"
"white")
"The list of colors available on a PC display under MS-DOS.")
(defun x-defined-colors (&optional frame)
"Return a list of colors supported for a particular frame.
The argument FRAME specifies which frame to try.
The value may be different for frames on different X displays."
x-colors)
(defvar x-last-selected-text nil)
(defvar x-select-enable-clipboard t
"Non-nil means cutting and pasting uses the clipboard.
This is in addition to the primary selection.")
(defun x-select-text (text &optional push)
(if x-select-enable-clipboard
(w16-set-clipboard-data text))
(setq x-last-selected-text text))
(defun x-get-selection-value ()
(if x-select-enable-clipboard
(let (text)
(condition-case c
(setq text (w16-get-clipboard-data))
(error (message "w16-get-clipboard-data:%s" c)))
(if (string= text "") (setq text nil))
(cond
((not text) nil)
((eq text x-last-selected-text) nil)
((string= text x-last-selected-text)
(setq x-last-selected-text text)
nil)
(t
(setq x-last-selected-text text))))))
(setq interprogram-cut-function 'x-select-text)
(setq interprogram-paste-function 'x-get-selection-value)
(defun x-frob-font-slant (font which)
font)
(fset 'query-fontset 'ignore)
(fset 'iconify-or-deiconify-frame 'ignore)
(fset 'set-default-font 'ignore)
(fset 'set-mouse-color 'ignore) (fset 'set-cursor-color 'ignore) (fset 'set-border-color 'ignore)
(defconst x-long-option-alist
'(("--name" . "-name")
("--title" . "-T")
("--reverse-video" . "-reverse")
("--foreground-color" . "-fg")
("--background-color" . "-bg")))
(defun msdos-handle-args (args)
(let ((rest nil))
(message "%s" args)
(while args
(let* ((this (car args))
(orig-this this)
completion argval)
(setq args (cdr args))
(if (string-match "^--[^=]*=" this)
(setq argval (substring this (match-end 0))
this (substring this 0 (1- (match-end 0)))))
(setq completion (try-completion this x-long-option-alist))
(if (eq completion t)
(setq this (cdr (assoc this x-long-option-alist)))
(if (stringp completion)
(let ((elt (assoc completion x-long-option-alist)))
(or elt
(error "Option `%s' is ambiguous" this))
(setq this (cdr elt)))
(setq argval nil this orig-this)))
(cond ((or (string= this "-fg") (string= this "-foreground"))
(or argval (setq argval (car args) args (cdr args)))
(setq default-frame-alist
(cons (cons 'foreground-color argval)
default-frame-alist)))
((or (string= this "-bg") (string= this "-background"))
(or argval (setq argval (car args) args (cdr args)))
(setq default-frame-alist
(cons (cons 'background-color argval)
default-frame-alist)))
((or (string= this "-T") (string= this "-name"))
(or argval (setq argval (car args) args (cdr args)))
(setq default-frame-alist
(cons
(cons 'title
(if (stringp argval)
argval
(let ((case-fold-search t)
i)
(setq argval (invocation-name))
(while
(setq i (string-match "[.*]" argval))
(aset argval i ?-))
argval)))
default-frame-alist)))
((or (string= this "-r")
(string= this "-rv")
(string= this "-reverse"))
(setq default-frame-alist
(cons '(reverse . t)
default-frame-alist)))
(t (setq rest (cons this rest))))))
(nreverse rest)))
(setq command-line-args (msdos-handle-args command-line-args))