PreviousUpNext

15.4.1633  src/lib/x-kit/xclient/src/window/keysym-to-ascii.pkg

## 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.pkg
herein


    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;




Comments and suggestions to: bugs@mythryl.org

PreviousUpNext