home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 3 / CDASC03.ISO / sorties / 2078 / abbrev.kml < prev    next >
Text File  |  1993-04-01  |  9KB  |  278 lines
  1. : > expand abbreviations;
  2. : > 0=Internal, 1=Select, 2=Common, 3=First, 4=Exact, 5=LongSel
  3. :EXPABBR
  4.     'editv set RCD'; N0 = 0; if ARG() then N0 = ARG(1);
  5.     MSG = 'macro KEYMSG'; MSG 'expand'; 'refresh';
  6.     ALT = 'set alt' ALT.1() ALT.2();
  7.     $AS = 'set autosave' AUTOSAVE.1(); 'set autosave OFF';
  8.     $WW = 'set wordwrap' WORDWRAP.1(); WW = 'set wordwrap OFF';
  9.     'modify msgline'; $MSG = CMDLINE.3(); 'set msgline ON';
  10.     'modify case'; $CS = CMDLINE.3(); 'cmsg'; 'cursor home';
  11.     'set insertmode ON'; 'text '; E = COLUMN.1();
  12.     T = 'set word' WORD.1(); 'set word ALPHANUM'; 'sos cl cl startword';
  13.     if \ DATATYPE(FIELD.2(),'A') then
  14.         do; 'sos cl'; if SPACECHAR() then 'sos cr'; else 'sos startword'; end;
  15.     T; C = CURSOR.4(); $C = 'macro LOCATECURS' CURSOR.3() C FILEID.1();
  16.     ABB = SUBSTR(FIELD.1(),C,E-C-1);
  17.     'cursor cmdline'; 'point .WINDLINE'; N = N0; T = '+';
  18.     CLC = 'nomsg clocate'; CLH = 'clocate -//'; DCH = 'sos delchar'; TFD = 'nomsg tfind';
  19.     RDK = 'readv KEY'; RLK = 'macro LASTKEY'; RSB = 'reset BLOCK';
  20.     do forever
  21.         'editv getf ABBREV'.N; if ABBREV.N = '' then leave;
  22.         if POS('[',ABBREV.N) = 0 then
  23.             do
  24.             $A = 'kedit' ABBREV.N; $A '(profile HIDDEN';
  25.             if RC > 1 then leave; ABBREV.N = FILEID.1(); MEC = MARGINS.3();
  26.             if LENGTH( ABB ) < MARGINS.1() then MEC = -1;
  27.             I = 'set alt' ALT.1()+\FOCUSTOF() ALT.2();
  28.             if POS('+',MEC) > 0 then 'move 1 :0'; I;
  29.             if T = '+' then 'backward *'; else 'forward *';
  30.             EXP = 'macro ABBRMEC' (0+MEC) || ( CASE.2()<CASE.3() & DATATYPE(SUBSTR(ABB,1,1),'U') ) ZONE.1();
  31.             end
  32.         else if POS(' ',ABB) > 0 then
  33.             do
  34.             MEC = 0; STR = SUBSTR(ABBREV.N,2,LENGTH(ABBREV.N)-2);
  35.             end
  36.         else
  37.             MEC = -1;
  38.         if MEC = -1 then
  39.             $C;
  40.         else if MEC = 0 then
  41.             do
  42.             $WR = 'set wrap' WRAP.1(); 'set wrap OFF'; 'set case MIXED IGNORE';
  43.             'cursor home'; 'cdelete :'E;
  44.             L = '-'; ID = 0; IABB = SUBSTR(ABB,1,POS(' ',ABB)-1); S = IABB;
  45.             do forever
  46.                 if L \= '' then CLC L''S''; if RC \= 0 then do; RSB; leave; end
  47.                 if \ FIRST() then
  48.                     do; 'sos cl'; if POS(FIELD.2(),STR) = 0 then iterate; 'sos cr'; end
  49.                 RSB; 'mark STREAM';
  50.                 'macro BYMODE \A-G\' SUBSTR('*',1+ID);
  51.                 if SPACECHAR() then do; 'sos cl'; 'mark' BLOCK.1(); end
  52.                 'sos blockstart'; 'editv getf ABBOPTI.'N;
  53.                 if ABBOPTI.N \= '' then
  54.                     do
  55.                     K = BLOCK.3();
  56.                     if \ ID then
  57.                         if DATATYPE(SUBSTR(FIELD.1(),K,BLOCK.5()-K+1),ABBOPTI.N) then
  58.                             iterate;
  59.                     end
  60.                 do forever
  61.                     MSG WORD( 'identifier occurrence' , ID+1 ) 'TAB=up S-TAB=down C-TAB=mode CURU/D=scroll ENTER=this';
  62.                     RDK; K = READV.1; L = '';
  63.                     if K = 'TAB' then do; L = '-'; leave; end
  64.                     else if K = 'S-TAB' then do; L = '+'; leave; end
  65.                     else if K = 'CURD' then 'forward 1 line';
  66.                     else if K = 'CURU' then 'backward 1 line';
  67.                     else if K = 'C-TAB' | K = 'ESC' | K = 'ENTER' then leave;
  68.                 end
  69.                 if K = 'C-TAB' then
  70.                     do
  71.                     'sos blockstart'; K = BLOCK.3();
  72.                     if ID then S = IABB;
  73.                     else S = SUBSTR( FIELD.1() , K , BLOCK.5()-K+2 );
  74.                     ID = \ ID; iterate;
  75.                     end
  76.                 if K = 'ESC' then RSB;
  77.                 if K = 'ESC' | K = 'ENTER' then leave;
  78.             end
  79.             $C;
  80.             if BLOCK() then do; 'copy BLOCK'; RSB; T = 0; 'sos endword cr'; 'text '; end
  81.             else 'text' ABB'';
  82.             $WR; $CS;
  83.             end
  84.         else if MEC = 1 then
  85.             do forever
  86.             if T \= 0 then do; TFD T''ABB''; I = RC; end
  87.             if I = 0 then L = CURLINE.3(); else 'top';
  88.             $C; 'cdelete :'E; WW; if I \= 0 then do; 'text' ABB''; leave; end
  89.             EXP L; T = 0; E = COLUMN.1(); CLH; DCH;
  90.             MSG 'expand... TAB=next S-TAB=previous C-BKSP=delete ESC=exit';
  91.             RDK; K = READV.1; 'text '; if K = 'C-TAB' then leave;
  92.             if K = 'ESC' then do; T = 0; I = 1; end
  93.             else if K = 'TAB' then T = '+';
  94.             else if K = 'S-TAB' then T = '-';
  95.             else if K = 'C-BKSP' then T = 'D';
  96.             else do; RLK; leave; end
  97.             $A;
  98.             if T = 'D' then do; 'delete 1'; T = '-'; end
  99.             end
  100.         else if MEC = 2 then
  101.             do
  102.             S = ABB; P = '';
  103.             do forever
  104.                 if S = '' then
  105.                     'top';
  106.                 else if T \= 0 then
  107.                     do
  108.                     TFD ''S'';
  109.                     if RC = 0 then
  110.                         do
  111.                         'point .TOPMATCH'; L = CURLINE.3();
  112.                         TFD '^'S''; if RC = 0 then 'up'; else 'bottom';
  113.                         L1 = UPPER( L ); L2 = UPPER( CURLINE.3() );
  114.                         if L1 = L2 then
  115.                             T = 0;
  116.                         else
  117.                             do Y = LENGTH(S)+1
  118.                             if SUBSTR(L1,Y,1) == SUBSTR(L2,Y,1) then iterate;
  119.                             S = SUBSTR(L,1,Y-1); L = S''; P = S;
  120.                             'locate .TOPMATCH'; 'up'; leave;
  121.                             end
  122.                         if SUBSTR( L , LENGTH( L ) ) = '' then
  123.                             do
  124.                             T = 1; TFD 'BLANK';
  125.                             S = SUBSTR( L , 1 , LENGTH(L)-1 ); L = S'';
  126.                             end
  127.                         end
  128.                     else if L1 = UPPER( L ) then
  129.                         do; T = 0; RLK; end
  130.                     else if P = '' then
  131.                         do; T = '00'; L = ABB''; end
  132.                     else
  133.                         do
  134.                         S = P; TFD ''S'';
  135.                         if RC = 0 then do; T = 0; L = CURLINE.3(); RLK; end
  136.                         else 'sos beep';
  137.                         end
  138.                     end
  139.                 $C; 'cdelete :'E; WW;
  140.                 if T \= 0 then 'text' L; else do; EXP L; leave; end
  141.                 E = COLUMN.1(); CLH; DCH;
  142.                 MSG 'expand... char=choice ESC=exit';
  143.                 RDK; K = READV.1; 'text '; if K = 'C-TAB' then leave;
  144.                 if K = 'ESC' then
  145.                     do; T = '00'; S = ''; L = ABB''; end
  146.                 else if K = 'ENTER' then
  147.                     T = 0;
  148.                 else
  149.                     do
  150.                     K = READV.2;
  151.                     if K << ' ' | READV.3 > 57 then do; K = ''; RLK; end; S = S||K;
  152.                     end
  153.                 $A;
  154.             end
  155.             end
  156.         else if MEC = 3 then
  157.             do
  158.             TFD ''ABB''; if RC = 0 then T = 0; L = CURLINE.3();
  159.             $C; if T = 0 then do; 'cdelete :'E; WW; EXP L; end
  160.             end
  161.         else if MEC = 4 then
  162.             do forever
  163.             TFD ''ABB''; I = RC; if I = 0 then L = CURLINE.3(); else 'top';
  164.             $C; if I \= 0 then leave;
  165.             'set case MIXED IGNORE IGNORE'; EXP L; I = RC; $CS;
  166.             if I = 0 then do; T = 0; leave; end; $A;
  167.             end
  168.         else if MEC = 5 then
  169.             do
  170.             do forever
  171.             if T \= 0 then do; TFD T''ABB''; I = RC; end
  172.             if I = 0 then
  173.                 do
  174.                 L = CURLINE.3(); 'cursor column'; 'sos cdn firstcol';
  175.                 'mark STREAM'; 'clocate //';
  176.                 'sos cr'; Y = FIELD.2(); 'sos cl'; if FIRST() then Y = 'L';
  177.                 if Y = 'L' then do; 'sos cup'; 'mark LINE'; end
  178.                 else do; 'sos cl'; if Y = 'B' then 'mark BOX'; else 'mark STREAM'; end
  179.                 end
  180.             else
  181.                 'top';
  182.             $C; 'nomsg cdelete :'E; E = COLUMN.1(); WW;
  183.             if I \= 0 then do; 'text' ABB''; leave; end
  184.             EXP L; T = 0; CLH; DCH;
  185.             MSG 'expand... TAB=next S-TAB=previous ESC=exit';
  186.             RDK; K = READV.1; 'text '; if K = 'C-TAB' then leave;
  187.             if K = 'ESC' then do; T = 0; I = 1; end
  188.             else if K = 'TAB' then T = '+';
  189.             else if K = 'S-TAB' then T = '-';
  190.             else do; RLK; leave; end
  191.             'delete BLOCK'; $A;
  192.             end
  193.             RSB;
  194.             end
  195.         else
  196.             $C;
  197.         'editv putf ABBREV'.N;
  198.         if T = '+' then N = N+1; else if T = '-' then N = N-1;
  199.         if T = 0 | N < N0 then leave;
  200.     end
  201.     if T == '0' then
  202.         do
  203.         'set stream OFF'; 'sos firstchar'; if FIELD.2() = '' then DCH;
  204.         EDC = 'sos endchar'; EDC 'cl'; if FIELD.2() = '' then DCH;
  205.         do forever
  206.             EDC; CLC '-//'; if RC \= 0 then leave;
  207.             DCH; 'split aligned'; 'down';
  208.             do forever
  209.                 EDC; CLC '-//'; if RC \= 0 then leave; DCH; 'sos instab';
  210.             end
  211.             'up';
  212.         end
  213.         end
  214.     else
  215.         'sos beep';
  216.     $C; 'set stream ON'; 'clocate //'; DCH;
  217.     $WW; 'text '; 'sos delback'; 'cdelete 0'; ALT; $AS; $MSG;
  218. : > hook for variants of mecanisms
  219. :ABBRMEC
  220.     Z = WORD( ARG(1) , 2 );
  221.     V = SUBSTR( ARG(1) , 6 , Z-1 ); V = SUBSTR( V , 1 , POS( ' ' , V' ' ) );
  222.     'macro ABBRMEC'WORD( ARG(1) , 1 ) || V || SUBSTR( ARG(1) , Z+5 );
  223. : > default mecanisms
  224. :ABBRMEC10
  225.     'macro USEASCII text #'SUBSTR( ARG(1) , POS( '' , ARG(1) ) + 1 );
  226. :ABBRMEC11
  227.     'macro CONVNAT U 2 macro USEASCII text ##'SUBSTR( ARG(1) , POS( '' , ARG(1) ) + 1 );
  228. :ABBRMEC20
  229.     'text 'SUBSTR( ARG(1) , POS( '' , ARG(1) ) + 1 );
  230. :ABBRMEC21
  231.     'macro ABBRMEC20' UPPER( ARG(1) );
  232. :ABBRMEC30
  233.     'macro ABBRMEC20' ARG(1);
  234. :ABBRMEC31
  235.     'macro ABBRMEC20' UPPER( ARG(1) );
  236. :ABBRMEC40
  237.     'nomsg change'ARG(1);
  238. :ABBRMEC41
  239.     'nomsg change'UPPER( ARG(1) );
  240. :ABBRMEC50
  241.     if \ AFTER() & BLOCK.1() = 'LINE' then 'split aligned';
  242.     'copy BLOCK'; 'sos blockend endchar';
  243.     'msg 'SUBSTR( ARG(1) , MAX( 2 , POS( '' , ARG(1) , 2 ) + 1 ) );
  244. : > show abbreviations
  245. :ALLABBR
  246.     $F = 'macro LOCATECURS -1 1' FILEID.1(); 'point .WINDLINE';
  247.     C = 1; M = 'msg ALLABBR'; T = ARG(1); N = WORD( T , 1 );
  248.     if DATATYPE( N , 'N' ) then T = SUBSTR( T , POS( ' ' , T ) + 1 );
  249.     else N = 0;
  250.     do N = N
  251.         'editv getf ABBREV'.N; if ABBREV.N = '' then leave;
  252.         'kedit' ABBREV.N '(profile HIDDEN'; if RC \= 0 then leave;
  253.         I = 'set alt' ALT.1()+\FOCUSTOF() ALT.2();
  254.         if POS( '+' , MARGINS.3() ) > 0 then 'move 1 :0'; I;
  255.         ABBREV.N = FILEID.1(); 'nomsg all' T;
  256.         if RC = 0 then
  257.             do forever
  258.             M 'SPACE=next CURU/D=scroll PLUS=input ESC=end BKSP=quit' T 'matches';
  259.             C = 0; RDK; K = READV.1;
  260.             if K = 'ESC' | K = 'SPACE' then
  261.                 leave;
  262.             else if K = 'BKSP' then
  263.                 do; 'quit'; leave; end
  264.             else if K = 'CURU' then
  265.                 'backward 1 line';
  266.             else if K = 'CURD' then
  267.                 'forward 1 line';
  268.             else if K = 'PLUS' & CASE.1() = 'MIXED' then
  269.                 do
  270.                 M 'input:'; 'readv CMD';
  271.                 if READV.1 \= '' then 'input' READV.1;
  272.                 end
  273.             end
  274.         'all'; 'top'; $F; 'editv putf ABBREV.'N;
  275.         if K = 'ESC' | K = 'BKSP' then leave;
  276.     end
  277.     if C then M 'no match -' N 'file(s)';
  278.