## keysym-to-ascii.pkg
#
# Translating X keysyms to vanilla ASCII characters.
#
# See also:
# src/lib/x-kit/xclient/src/window/keymap-ximp.pkg# Compiled by:
# src/lib/x-kit/xclient/xclient-internals.sublib# The implementation of keysym to ASCII-string translation tables.
#
# NOTE: we could probably implement the default namings using the red-black tree,
# and thus avoid the ugly ad hoc Xlib code. XXX BUGGO FIXME
### "Music is the pleasure that the human mind experiences
### from counting without being aware that it is counting."
###
### -- Leibniz
stipulate
package kb = keys_and_buttons; # keys_and_buttons is from src/lib/x-kit/xclient/src/wire/keys-and-buttons.pkg package ks = keysym; # keysym is from src/lib/x-kit/xclient/src/window/keysym.pkg package xt = xtypes; # xtypes is from src/lib/x-kit/xclient/src/wire/xtypes.pkg #
nb = log::note_on_stderr; # log is from src/lib/std/src/log.pkgherein
package keysym_to_ascii
: (weak) Keysym_To_Ascii # Keysym_To_Ascii is from src/lib/x-kit/xclient/src/window/keysym-to-ascii.api {
stipulate
# This string maps an ascii character "C" to "^C".
cntrl_map = "\
\\x00\x01\x02\x03\x04\x05\x06\x07\
\\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\
\\x10\x11\x12\x13\x14\x15\x16\x17\
\\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\
\\x00\x21\x22\x23\x24\x25\x26\x27\
\\x28\x29\x2a\x2b\x2c\x2d\x2e\x1f\
\\x30\x31\x00\x1b\x1c\x1d\x1e\x1f\
\\x7f\x39\x3a\x3b\x3c\x3d\x3e\x3f\
\\x00\x01\x02\x03\x04\x05\x06\x07\
\\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\
\\x10\x11\x12\x13\x14\x15\x16\x17\
\\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\
\\x00\x01\x02\x03\x04\x05\x06\x07\
\\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\
\\x10\x11\x12\x13\x14\x15\x16\x17\
\\x18\x19\x1a\x1b\x1c\x1d\x1e\x7f\
\";
fun control x
=
(string::get_byte_as_char (cntrl_map, x))
except
_ = (char::from_int x);
# Translation tables are implemented as red-black trees
#
# 2010-01-15 CrT: Why on Earth do we need yet another
# implementation of red-black trees?!
# Should convert this to use standard
# ones. XXX BUGGO FIXME.
Color = RED | BLACK;
Tree = NIL
| NODE { key: Int,
color: Color,
namings: List( (xt::Modifier_Keys_State, String) ),
left: Tree,
right: Tree
};
fun insert_naming (t, k, state, v)
=
f t
where
fun upd (NODE { key, color, namings, left, right }, c, l, r)
=>
NODE { key, color=>c, namings, left=>l, right=>r };
upd (NIL, _, _, _) => raise exception DIE "Bug: Unsupported case in insert_naming/upd.";
end;
# Insert (state, v) into the naming list of t,
# removing any namings subsumed by state:
#
fun ins (t as NODE { key, color, namings, left, right } )
=>
{ b = case (f namings)
#
THE b => (state, v) ! b;
NULL => (state, v) ! namings;
esac
where
fun f ((b as (s, _)) ! r)
=>
case (kb::modifier_keys_states_match (s, state), f r)
#
(FALSE, NULL ) => NULL;
(TRUE, NULL ) => THE r;
(FALSE, THE r') => THE (b ! r');
(TRUE, x ) => x;
esac;
f [] => NULL;
end;
end;
NODE { key, color, namings=>b, left, right };
};
ins NIL => raise exception DIE "Bug: Unsupported case in insert_naming/ins";
end;
fun f NIL => NODE
{ key => k,
color => RED,
namings => [ (state, v) ],
#
left => NIL,
right => NIL
};
f (t as NODE { key, color=>RED, left, right, ... } )
=>
if (key == k) ins t;
elif (k < key) upd (t, RED, f left, right);
else upd (t, RED, left, f right);
fi;
f (t as NODE { key, color=>BLACK, left, right, ... } )
=>
if (key == k)
ins t;
elif (k < key)
case (f left)
(l as NODE { color=>RED, left=>ll, right=>(lr as NODE { color=>RED, left=>lrl, right=>lrr, ... } ), ... } )
=>
case right
(r as NODE { color=>RED, left=>rl, right=>rr, ... } )
=>
upd (t, RED, upd (l, BLACK, ll, lr), upd (r, BLACK, rl, rr));
r => upd (lr, BLACK, upd (l, RED, ll, lrl), upd (r, RED, lrr, r));
esac;
(l as NODE { color=>RED, right=>lr, left=>(ll as NODE { color=>RED, left=>lll, right=>llr, ... } ), ... } )
=>
case right
(r as NODE { color=>RED, left=>rl, right=>rr, ... } )
=>
upd (t, RED, upd (l, BLACK, ll, lr), upd (r, BLACK, rl, rr));
r => upd (l, BLACK, ll, upd (t, RED, lr, r));
esac;
l => upd (t, BLACK, l, right);
esac;
else
case (f right)
(r as NODE { color=>RED, right=>rr, left=>(rl as NODE { color=>RED, left=>rll, right=>rlr, ... } ), ... } )
=>
case left
(l as NODE { color=>RED, left=>ll, right=>lr, ... } )
=>
upd (t, RED, upd (l, BLACK, ll, lr), upd (r, BLACK, rl, rr));
l => upd (rl, BLACK, upd (t, RED, l, rll), upd (r, BLACK, rlr, rr));
esac;
(r as NODE { color=>RED, left=>rl, right=>(rr as NODE { color=>RED, left=>rrl, right=>rrr, ... } ), ... } )
=>
case left
(l as NODE { color=>RED, left=>ll, right=>lr, ... } )
=>
upd (t, RED, upd (l, BLACK, ll, lr), upd (r, BLACK, rl, rr));
l => upd (r, BLACK, upd (t, RED, l, rl), rr);
esac;
r => upd (t, BLACK, left, r);
esac;
fi;
end;
end; # fun insert_naming
fun find_naming (t, k, state)
=
find t
where
fun find NIL
=>
{ msg = sprintf "keysym %d not found -- find_naming/fin/NIL in keysym-to-ascii.pkg" k;
raise exception DIE msg;
};
find (NODE { key, namings, left, right, ... } )
=>
if (key == k)
#
fun get_naming []
=>
{ msg = sprintf "Keysym %d not found -- find_naming/find/NODE in keysym-to-ascii.pkg." k;
raise exception DIE msg;
};
get_naming ((s, v) ! r)
=>
kb::modifier_keys_states_match (state, s)
##
?? v
:: get_naming r;
end;
get_naming namings;
else
key > k ?? find left
:: find right;
fi;
end;
end;
fun default_naming (k, state)
=
{
k' = unt::from_int k;
high_bytes = unt::(<<) (k', 0u8);
fun char_to_string c
=
if (kb::control_key_is_set state)
#
string::from_char (control c);
else
string::from_char (char::from_int c);
fi;
# Map Misc keysyms to ascii equivalents.
#
fun standardize 0ux00AD => char_to_string 0x2D; # hyphen => "-"
standardize 0uxFF08 => "<backspace>"; # Backspace key.
standardize 0uxFF09 => char_to_string 0x09; # Tab => HT
standardize 0uxFF0A => char_to_string 0x0A; # Linefeed => LF
standardize 0uxFF0B => "<clear>"; #
standardize 0uxFF0D => char_to_string 0x0D; # Return => CR
#
standardize 0uxFF13 => "<pause>"; #
standardize 0uxFF14 => "<scrollLock>"; # Scroll Lock key.
standardize 0uxFF15 => "<sysReq>"; # SysReq key.
#
standardize 0uxFF1B => char_to_string 0x1B; # Escape => ESC
#
standardize 0uxFF20 => "<leftTab>"; # Shift-tab key. Sometimes MultiKey.
standardize 0uxFF21 => "<Kanji>"; #
standardize 0uxFF22 => "<Muhenkan>"; #
standardize 0uxFF23 => "<Henkan>"; #
standardize 0uxFF24 => "<Romaji>"; #
standardize 0uxFF25 => "<Hiragana>"; #
standardize 0uxFF26 => "<Katakana>"; #
standardize 0uxFF27 => "<HiraganaKatakana>"; #
standardize 0uxFF28 => "<Zenkaku>"; #
standardize 0uxFF29 => "<Hankaku>"; #
standardize 0uxFF2A => "<ZenkakuHankaku>"; #
standardize 0uxFF2B => "<Touroku>"; #
standardize 0uxFF2C => "<Massyo>"; #
standardize 0uxFF2D => "<KanaLock>"; #
standardize 0uxFF2E => "<KanaShift>"; #
standardize 0uxFF2F => "<EisuShift>"; #
standardize 0uxFF30 => "<EisuToggle>"; #
standardize 0uxFF37 => "<KanjiBangou>"; #
standardize 0uxFF3D => "<ZenKoho>"; #
standardize 0uxFF3E => "<MaeKoho>"; #
#
standardize 0uxFF50 => "<home>"; # Home key. # We use all-lowercase all through here to match emacs tradition.
standardize 0uxFF51 => "<left>"; # Left-arrow key.
standardize 0uxFF52 => "<up>"; # Up-arrow key.
standardize 0uxFF53 => "<right>"; # Right-arrow key.
standardize 0uxFF54 => "<down>"; # Down-arrow key.
standardize 0uxFF55 => "<pageUp>"; # Page Up key.
standardize 0uxFF56 => "<pageDown>"; # Page Down key.
standardize 0uxFF57 => "<end>"; # End key.
standardize 0uxFF58 => "<begin>"; # Begin key.
#
standardize 0uxFF60 => "<select>"; # Select key.
standardize 0uxFF61 => "<printScr>"; # Print-screen key.
standardize 0uxFF62 => "<execute>"; # Execute key.
standardize 0uxFF63 => "<insert>"; # Insert key.
#
standardize 0uxFF65 => "<undo>"; # Undo key.
standardize 0uxFF66 => "<redo>"; # Redo key.
standardize 0uxFF67 => "<menu>"; # Menu key.
standardize 0uxFF68 => "<find>"; # Find key.
standardize 0uxFF69 => "<cancel>"; # Cancel key.
standardize 0uxFF6A => "<help>"; # Help key.
standardize 0uxFF6B => "<break>"; # Break key.
#
standardize 0uxFF7F => "<numLock>"; # Num Lock key.
standardize 0uxFF80 => char_to_string 0x20; # KP_Space => " " ("KP_"=="Keypad_" here.)
#
standardize 0uxFF8D => char_to_string 0x0D; # KP_Enter => CR
#
standardize 0uxFFAA => "*"; # KP_Multiply => "*"
standardize 0uxFFAB => "+"; # KP_Add => "+"
standardize 0uxFFAD => "-"; # KP_Subtract => "-"
standardize 0uxFFAF => "/"; # KP_Divide => "/"
standardize 0uxFFB1 => "1"; # KP_1 => "1"
standardize 0uxFFB2 => "2"; # KP_2 => "2"
standardize 0uxFFB3 => "3"; # KP_3 => "3"
standardize 0uxFFB4 => "4"; # KP_4 => "4"
standardize 0uxFFB5 => "5"; # KP_5 => "5"
standardize 0uxFFB6 => "6"; # KP_6 => "6"
standardize 0uxFFB7 => "7"; # KP_7 => "7"
standardize 0uxFFB8 => "8"; # KP_8 => "8"
standardize 0uxFFB9 => "9"; # KP_9 => "9"
standardize 0uxFFBD => "="; # KP_Equal => "="
standardize 0uxFFBE => "<f1>"; # F1 key.
standardize 0uxFFBF => "<f2>"; # F2 key.
standardize 0uxFFC0 => "<f3>"; # F3 key.
standardize 0uxFFC1 => "<f4>"; # F4 key.
standardize 0uxFFC2 => "<f5>"; # F5 key.
standardize 0uxFFC3 => "<f6>"; # F6 key.
standardize 0uxFFC4 => "<f7>"; # F7 key.
standardize 0uxFFC5 => "<f8>"; # F8 key.
standardize 0uxFFC6 => "<f9>"; # F9 key.
standardize 0uxFFC7 => "<f10>"; # F10 key.
standardize 0uxFFC8 => "<f11>"; # F11 key.
standardize 0uxFFC9 => "<f12>"; # F12 key.
standardize 0uxFFCA => "<f13>"; # F13 key.
standardize 0uxFFCB => "<f14>"; # F14 key.
standardize 0uxFFCC => "<f15>"; # F15 key.
standardize 0uxFFCD => "<f16>"; # F16 key.
standardize 0uxFFCE => "<f17>"; # F17 key.
standardize 0uxFFCF => "<f18>"; # F18 key.
standardize 0uxFFD0 => "<f19>"; # F19 key.
standardize 0uxFFD1 => "<f20>"; # F20 key.
standardize 0uxFFD2 => "<f21>"; # F21 key.
standardize 0uxFFD3 => "<f22>"; # F22 key.
standardize 0uxFFD4 => "<f23>"; # F23 key.
standardize 0uxFFD5 => "<f24>"; # F24 key.
standardize 0uxFFD6 => "<f25>"; # F25 key.
standardize 0uxFFD7 => "<f26>"; # F26 key.
standardize 0uxFFD8 => "<f27>"; # F27 key.
standardize 0uxFFD9 => "<f28>"; # F28 key.
standardize 0uxFFDA => "<f29>"; # F29 key.
standardize 0uxFFDB => "<f30>"; # F30 key.
standardize 0uxFFDC => "<f31>"; # F31 key.
standardize 0uxFFDD => "<f32>"; # F32 key.
standardize 0uxFFDE => "<f33>"; # F33 key.
standardize 0uxFFDF => "<f34>"; # F34 key.
standardize 0uxFFE0 => "<f35>"; # F35 key.
standardize 0uxFFE1 => "<leftShift>"; # Left Shift key.
standardize 0uxFFE2 => "<rightShift>"; # Right Shift key.
standardize 0uxFFE3 => "<leftCtrl>"; # Left Ctrl key.
standardize 0uxFFE4 => "<rightCtrl>"; # Right Ctrl key.
standardize 0uxFFE5 => "<capsLock>"; # Caps Lock key.
standardize 0uxFFE7 => "<leftMeta>"; # Left Meta key.
standardize 0uxFFE8 => "<rightMeta>"; # Right Meta key.
standardize 0uxFFE9 => "<leftAlt>"; # Left Alt key.
standardize 0uxFFEA => "<rightAlt>"; # Right Alt key.
standardize 0uxFFEC => "<cmd>"; # Windows/Apple key.
standardize 0uxFFFF => "<delete>"; # Delete key.
#
standardize c # handle keypad "*+,-./0123456789"
=>
if (0uxFFAA <= c and c <= 0uxFFB9)
#
char_to_string (unt::to_int_x (unt::bitwise_and (c, 0ux7f)));
else
"";
fi;
end;
case (unt::(>>) (k', 0u8))
#
0u0 => if (k' == 0ux00AD) char_to_string 0x2D;
else char_to_string k;
fi;
0uxFF => standardize k';
_ => "";
esac;
};
herein
Keysym_To_Ascii_Mapping
=
KEYSYM_TO_ASCII_MAPPING Tree;
default_keysym_to_ascii_mapping
=
KEYSYM_TO_ASCII_MAPPING NIL;
fun rebind_keysym (KEYSYM_TO_ASCII_MAPPING t)
=
\\ (ks::KEYSYM ks, modkeys, v)
=>
{ state = kb::make_modifier_keys_state modkeys;
#
KEYSYM_TO_ASCII_MAPPING (insert_naming (t, ks, state, v));
};
(ks::NO_SYMBOL, _, _)
=>
{ msg = "Bug: Unsupported case in rebind_keysym -- ";
log::fatal msg;
raise exception DIE msg;
};
end;
fun translate_keysym_to_ascii (KEYSYM_TO_ASCII_MAPPING t)
=
\\ (ks::KEYSYM k, state)
=>
find_naming (t, k, state)
except
_ = default_naming (k, state);
(ks::NO_SYMBOL, _) # We get these on release of either shift key. I don't know if this is a bug or a feature. -- CrT 2015-01-02
=>
{
"<NO_SYMBOL>";
};
end;
end; # stipulate
}; # keysym_to_ascii
end;