64 lines
1.9 KiB
Factor
64 lines
1.9 KiB
Factor
USING: arrays assocs combinators formatting fry grouping.extras
|
|
kernel literals math math.parser multiline sequences
|
|
splitting.extras unicode ;
|
|
IN: rosetta-code.abbr-simple
|
|
|
|
CONSTANT: input $[
|
|
"riG rePEAT copies put mo rest types fup. 6 "
|
|
"poweRin" append
|
|
]
|
|
|
|
<< ! Make the following two words available at parse time.
|
|
|
|
: abbr-pair ( first second -- seq/f )
|
|
{
|
|
{ [ 2dup drop [ digit? ] all? ] [ 2drop f ] }
|
|
{
|
|
[ 2dup nip [ Letter? ] all? ]
|
|
[ drop >upper 0 2array ]
|
|
}
|
|
[ [ >upper ] [ string>number ] bi* 2array ]
|
|
} cond ;
|
|
|
|
: parse-commands ( seq -- seq )
|
|
" \n" split-harvest [ abbr-pair ] 2clump-map sift ;
|
|
|
|
>>
|
|
|
|
CONSTANT: commands $[
|
|
HEREDOC: END
|
|
add 1 alter 3 backup 2 bottom 1 Cappend 2 change 1 Schange
|
|
Cinsert 2 Clast 3 compress 4 copy 2 count 3 Coverlay 3 cursor 3
|
|
delete 3 Cdelete 2 down 1 duplicate 3 xEdit 1 expand 3 extract
|
|
3 find 1 Nfind 2 Nfindup 6 NfUP 3 Cfind 2 findUP 3 fUP 2 forward
|
|
2 get help 1 hexType 4 input 1 powerInput 3 join 1 split 2
|
|
spltJOIN load locate 1 Clocate 2 lowerCase 3 upperCase 3 Lprefix
|
|
2 macro merge 2 modify 3 move 2 msg next 1 overlay 1 parse
|
|
preserve 4 purge 3 put putD query 1 quit read recover 3 refresh
|
|
renum 3 repeat 3 replace 1 Creplace 2 reset 3 restore 4 rgtLEFT
|
|
right 2 left 2 save set shift 2 si sort sos stack 3 status
|
|
4 top transfer 3 type 1 up 1
|
|
END
|
|
parse-commands
|
|
]
|
|
|
|
: valid-abbrevs ( assoc seq -- assoc )
|
|
dup '[ [ _ head? ] [ _ length <= ] bi* and ] assoc-filter ;
|
|
|
|
: find-command ( seq -- seq )
|
|
>upper [ commands ] dip valid-abbrevs
|
|
[ "*error*" ] [ first first ] if-empty ;
|
|
|
|
: (find-commands) ( seq -- seq )
|
|
" " split-harvest [ find-command ] map " " join ;
|
|
|
|
: find-commands ( seq -- seq )
|
|
dup empty? not [ (find-commands) ] when ;
|
|
|
|
: show-commands ( seq -- )
|
|
dup find-commands " Input: \"%s\"\nOutput: \"%s\"\n" printf
|
|
;
|
|
|
|
: main ( -- ) input "" [ show-commands ] bi@ ;
|
|
|
|
MAIN: main
|