120 REMark
127 REMark General kbd routines
128 fbin$=dv$&fpre$&'bin':fnew$=dv$&fpre$&'new':fdat$=dv$&fpre$&'dat'
130 init:readlayout:pleasewait$'Initialising translations':readtranslate
140 RESTORE :dohelp
150 REPeat main
160  CURSOR ike%(191),iky%(191)+5:PRINT hx$(iksc%(q%)DIV 16+1);hx$(iksc%(q%)MOD 16+1)
170  highlight q%,2:getkey$:highlight q%,2
180  c%=CODE(c$):s=c%:SELect s
190  =192,200,208,216:c%=c%DIV 8&&3:tryd:NEXT main
200  =232,234,236,238,240,242:do%=c%DIV 2MOD 2:docommand c%DIV 4-59
205  =237,239:do%=c%=239:savekey:dumpkdef
210  =244:togshift
220  =248:ibmshift 6
230  =9:c%=q%:q%=q2%:q2%=c%
240  =10,32:do%=c%=10:c%=iksc%(q%):s=c%:SELect s
250   =mf3min%TO mf3max%:IF scw%(c%,0)=1:ibmshift scw%(c%,1):ELSE ibmkey
260   =156,192TO 194:qlshift c%&&3
270   =195TO 255:qlkey c%&&63
280   =168TO 191:IF c%&&1AND seltype%<2OR NOT wd%(c%&&1):burp:NEXT main
290    make2nd c%&&1:bittable(c%-168)DIV 8,c%&&1,c%DIV 2&&3
300   =164TO 167:make2nd c%>165:seltype%=c%&&3:context
310   =162,163:make2nd c%&&1:wd%(sel2nd%)=0:context
320   =159TO 161:docommand c%-160
330   =158:EXIT main:END SELect
340  =27:EXIT main:=REMAINDER :burp:END SELect
350  END REPeat main:say1$'Finished.':newhigh$''
360 :
370 DEFine PROCedure getkey$:LOCal k%,s,lp:REPeat lp
380   c$=INKEY$(9||-(NOT hsh)):IF c$<>'':RETurn
390   c%=PEEK_W(hsh+74)^^128:k%=c%DIV 256&&255:IF k%=key%OR c%&&255:NEXT lp
400   s=k%:SELect s=mf3min%TO mf3max%:CURSOR ike%(192),iky%(192)+5:PRINT hx$(k%DIV 16+1);hx$(k%MOD 16+1):key%=k%
410   END REPeat lp:END DEFine
420 :
430 DEFine PROCedure burp:BEEP 9999,99:END DEFine
440 :
450 DEFine PROCedure tryd:LOCal i%,s,lp:i%=q%
460  IF c%<>3:IF ikf%(i%)=2:i%=i%-22
470  REPeat lp
480   s=c%:SELect s
490   =0:i%=i%-1:IF NOT (i%+1)MOD cols%:RETurn
500   =1:i%=i%+1:IF NOT i%MOD cols%:RETurn
510   =2:i%=i%-cols%:IF i%<0:RETurn
520   =3:i%=i%+cols%:IF i%>ik%:RETurn
530    END SELect :IF iksc%(i%):q%=i%:RETurn
540   IF ikf%(i%)<>1:c%=ikf%(i%)DIV bit%(2*c%)&&3:ELSE IF c%<2:c%=3
550   END REPeat lp:END DEFine
560 :
570 DEFine PROCedure loadkey:LOCal u%,s%,s,v
580  DIM acs%(2,1),wd%(1):seltype%=scw%(selibm%,0)DIV 4096
590  FOR s=0,1
600   s%=s:u%=scw%(selibm%,s%):wd%(s%)=u%&&63
610   FOR v=0TO 2:acs%(v,s%)=u%DIV 256&&2||u%DIV 64&&1:u%=u%DIV 2
620   END FOR s:END DEFine
630 :
640 DEFine PROCedure savekey:LOCal u%,v%,s%,s,v
650  FOR s=0,1
660   s%=s:u%=(seltype%||NOT seltype%)*8*NOT s%
670   FOR v=2TO 0STEP -1:v%=v:u%=u%*2||acs%(v%,s%)DIV 2*8||acs%(v%,s%)MOD 2
680   scw%(selibm%,s%)=u%*64||wd%(s%):END FOR s:END DEFine
690 :
700 DEFine PROCedure context:LOCal s%,t%,u%,a$,s,t
710  IF seltype%<2:u%=acs%(2,0)*16+acs%(1,0)*4+acs%(0,0):seltype%=u%<>12AND u%<>3AND u%OR NOT wd%(0)MOD 64
720  sel2nd%=selshift%&&9AND seltype%>1OR seltype%=3AND selshift%<64
730  a$=CHR$(selibm%)&CHR$(164+seltype%)
740  u%=selshift%*2
750  FOR s=0TO 6:u%=u%DIV 2:IF u%&&1:a$=a$&CHR$(ibmshf%(s))
760  FOR t=0TO seltype%>1
770   t%=t:u%=wd%(t):IF u%
780    IF t%=sel2nd%:a$=a$&CHR$(192+u%)
790    FOR s=0TO 2:s%=s:a$=a$&CHR$(s%*8+acs%(s%,t%)*2+t%+168)
800    ELSE
810    a$=a$&CHR$(162+t%)
820    END IF :END FOR t
830  IF wd%(sel2nd%)
840   u%=selshift%||selshift%DIV 8:IF sel2nd%:IF seltype%=3AND selshift%>=64OR seltype%=2:u%=u%&&-2
850   FOR s=0TO 2
860    s%=s:IF u%&&1AND acs%(s%,sel2nd%)<2XOR acs%(s%,sel2nd%)&&1:a$=a$&CHR$(192+s%)
870    u%=u%DIV 2:END FOR s:END IF :newhigh$a$:END DEFine
880 :
890 DEFine PROCedure newhigh$(h$):LOCal j%,k%,i,lp:high$='x'&high$&'x'
900  FOR i=1TO LEN(h$)
910   j%=CODE(h$(i)):k%=LEN(high$):REPeat lp
920    k%=k%-1:IF k%=1:toggle:EXIT lp
930    IF CODE(high$(k%))=j%:high$=high$(1TO k%-1)&high$(k%+1TO):EXIT lp
940    END REPeat lp:END FOR i
950  FOR i=2TO LEN(high$)-1:j%=CODE(high$(i)):toggle
960  high$=h$:END DEFine
970 :
980 DEFine PROCedure highlight(j%,t%):LOCal w0%,w1%,x%,y0%,y1%,z%
990  OVER-1:x%=ike%(j%):y0%=iky%(j%):y1%=y0%+h%:w1%=ikw%(j%):w0%=w1%:IF ikf%(j%)=2:y0%=y0%-h%:w0%=ikw%(j%-22)
1000  IF w0%=w1%
1010   BLOCK w0%-1,y1%-y0%-1,x%-w0%+1,y0%+1,t%
1020   ELSE z%=w0%<w1%
1030   BLOCK w0%-1,h%+z%-1,x%-w0%+1,y0%+1,t%
1040   BLOCK w1%-1,h%-z%,x%-w1%+1,y1%-h%+z%,t%
1050   END IF :OVER 0:END DEFine
1060 :
1070 DEFine PROCedure toggle:highlight kat%(j%),4:END DEFine
1080 :
1090 DEFine PROCedure togshift:IF selshift%&&9:selshift%=selshift%&&-10:ELSE selshift%=selshift%||8
1100  context:END DEFine
1110 :
1120 DEFine PROCedure ibmshift(s%):selshift%=bit%(s%)^^selshift%:context:END DEFine
1130 :
1140 DEFine PROCedure ibmkey:IF selibm%=c%:RETurn
1150  savekey:selibm%=c%:loadkey:context:END DEFine
1160 :
1170 DEFine PROCedure qlshift(s%)
1180  acs%(s%,sel2nd%)=acs%(s%,sel2nd%)^^1:context:END DEFine
1190 :
1200 DEFine PROCedure qlkey(k%)
1210  wd%(sel2nd%)=k%:context:END DEFine
1220 :
1230 DEFine PROCedure bittable(s%,t%,v%)
1240  acs%(s%,t%)=v%:context:END DEFine
1250 :
1260 DEFine PROCedure make2nd(v%):IF v%=sel2nd%:RETurn
1270  sel2nd%=v%:IF sel2nd%
1280   IF seltype%<=2
1290    seltype%=2:IF (selshift%&&9)=0:selshift%=selshift%||8
1300    ELSE selshift%=selshift%&&63:END IF :RETurn :END IF
1310  IF seltype%=3:selshift%=selshift%||64
1320  selshift%=selshift%&&118:END DEFine
1330 :
1340 DEFine PROCedure docommand(c%):newhigh$CHR$(160+c%)&high$
1350  IF c%<0:dohelp:ELSE IF c%:savekey:doput:ELSE doget:loadkey
1360  context:END DEFine
1370 :
1380 DEFine PROCedure doget:LOCal xw%(58),xb%(mf3max%),l%,n%,w0%,w1%
1390  LOCal j%,k%,c%,x%,j,s,t$
1400  IF checkheader%:RETurn
1410  FOR j=59-n%TO 58:xw%(j)=getw%
1420  FOR j=mf3min%TO mf3max%:xb%(j)=getb%
1430  IF mf3len%&&1:w0%=getb%
1440  FOR j=0TO 9:w0%=getw%
1450  IF checkrtshsh%:RETurn
1460  CLOSE#3:say2$t$,'Loaded translations from '&fbin$
1470  FOR j=mf3min%TO mf3max%
1480   j%=j:k%=0:w0%=xb%(j%):w1%=0:c%=w0%&&63:x%=w0%DIV 64:s=w0%:SELect s
1490   =3TO 63,67TO 127,131TO 191:k%=1:w0%=x%*576||c%
1500   =192TO 249:x%=xw%(c%+1):w0%=x%&&63:x%=x%DIV 64^^56:IF x%>=0
1510     k%=1:IF w0%:w0%=x%MOD 64*64||w0%
1520     ELSE
1530     k%=x%DIV 8&&1||2:w0%=x%MOD 64*64||512||w0%
1540     x%=xw%(c%):IF x%&&63:w1%=x%&&4095^^3584||(k%=2)*512
1550     END IF
1560   =250TO 255:w1%=w0%-250:w0%=1
1570   =0:=REMAINDER :infail$'codebyte='&w0%:RETurn
1580    END SELect :scw%(j%,0)=k%*4096+w0%:scw%(j%,1)=w1%:END FOR j
1590  j%=ibmshf%(6):scw%(j%,0)=1:scw%(j%,1)=6:REMark NumLock is fixed
1600  END DEFine
1610 :
1620 DEFine FuNction getw%:RETurn ((getb%-128&&255)-128)*256+getb%:END DEFine
1630 :
1640 DEFine FuNction getb%:RETurn CODE(getc$):END DEFine
1650 :
1660 DEFine FuNction getc$:RETurn INKEY$(#3;-1):END DEFine
1670 :
1680 DEFine FuNction gets$(l%):LOCal a$,j:a$=''
1690  FOR j=1TO l%:a$=a$&getc$
1700  RETurn a$:END DEFine
1710 :
1720 DEFine PROCedure putw%(w%):putb%w%DIV 256:putb%w%:END DEFine
1730 :
1740 DEFine PROCedure putb%(b%):putc$CHR$(b%):END DEFine
1750 :
1760 DEFine PROCedure putc$(c$):PRINT#4;c$;:END DEFine
1770 :
1780 DEFine PROCedure puts$(t$):PRINT#4;t$;:END DEFine
1790 :
1800 DEFine PROCedure prompt$(a$,b$):LOCal t$:CLS#0
1810  IF Minnie%>196:INPUT#0;a$&':'!b$TO:RETurn
1820  INPUT#0;a$&' [';b$&']:'!t$:IF t$<>'':b$=t$
1830  END DEFine
1840 :
1850 DEFine PROCedure infail$(b$):CLOSE#3:say2$'Invalid structure in '&fbin$,b$:END DEFine
1860 :
1870 DEFine FuNction checkheader%:LOCal s
1880  IF do%:prompt$'Source file name',fbin$
1890  say1$'Loading '&fbin$:OPEN_IN#3;fbin$
1900  IF getw%<>bsrl%:infail$'not bsr.l':RETurn 1
1910  n%=getw%:IF n%&&-32767:infail$'odd/negative offset':RETurn 1
1920  l%=getw%:IF l%&&-64:infail$'text too long':RETurn 1
1930  t$=gets$(l%):IF l%&&1:k%=getb%
1940  n%=(n%-l%-l%MOD 2-mf3len%-30)DIV 2:s=n%:SELect s=1TO 58:RETurn 0
1950  infail$'too few/many table words':RETurn 1:END DEFine
1960 :
1970 DEFine FuNction checkrtshsh%
1980  IF getw%<>rts%:infail$'rts':RETurn 1
1990  IF gets$(4)<>hsh$:infail$hsh$:RETurn 1
2000  RETurn 0:END DEFine
2010 :
2020 DEFine PROCedure doput:LOCal xw%(9),d%,j%,k%,l%,n%,p%,j
2030  LOCal wds$,t$:IF checkreach%:RETurn
2040  pleasewait$'Building and optimising table.':p%=1:IF insertpass%
2050   p%=0:say2$t$,'Retrying without unreferenced translations.'
2060   IF insertpass%:say2$'*** The translations are too complex to store! ***',t$:RETurn
2070   END IF :IF checkheader%:RETurn
2080  FOR j=-n%-(mf3len%+1)DIV 2TO 9:xw%(j MOD 10)=getw%
2090  IF checkrtshsh%:RETurn
2100  IF do%:prompt$'Create file name',fnew$
2110  pleasewait$'Creating '&fnew$&' from '&fbin$:DELETE fnew$:OPEN_NEW#4;fnew$
2120  putw%bsrl%:putw%d%*2+l%+l%MOD 2+mf3len%+mf3len%MOD 2+30:putw%l%:puts$t$:IF l%&&1:putb%k%
2130  FOR j=1TO d%:c%=j*5-4:putw%((((wds$(c%)=',')*-64+wds$(c%+1))*8+wds$(c%+2))*8+wds$(c%+3))*8+wds$(c%+4)
2140  FOR j=mf3min%TO mf3max%:j%=j:putb%vect%
2150  IF mf3len%&&1:putb%0
2160  FOR j=0TO 9:putw%xw%(j)
2170  putw%rts%:puts$'HSH%'
2180  REPeat lp:PRINT#4;INKEY$(#3;-1);:IF EOF(#3):EXIT lp
2190  CLOSE#3:CLOSE#4:say1$'Created '&fnew$:END DEFine
2200 :
2210 DEFine FuNction checkreach%:LOCal xw%(63),b%,c%,j%,k%,j,t$
2220  FOR j=mf3min%TO mf3max%
2230   j%=j:b%=scw%(j%,0):k%=b%DIV 4096:IF k%
2240    setbits%(k%>1)*512||b%&&4095
2250    IF k%>1:setbits%(k%=2)*512||scw%(j%,1)
2260    END IF :END FOR j:j%=0
2270  FOR j=3TO 63:IF xw%(j)<>255:j%=j:EXIT j
2280  IF NOT j%:RETurn 0
2290  FOR j=0TO 7:IF bit%(j)&&~~xw%(j%):b%=j:EXIT j
2300  t$=CHR$(192+j%):say2$'Unreachable QL key combination','Please assign:'
2310  FOR j=1TO 3:t$=t$&FILL$(CHR$(191+j),b%&&1):PRINT#0;!'-+'(b%MOD 2+1);'SCA'(j);:b%=b%DIV 2
2320  PRINT#0;!j%DIV 8;j%&&7:newhigh$t$:getkey$:RETurn 0:END DEFine :REMark ret 1
2330 :
2340 DEFine PROCedure setbits%(v%)
2350  b%=17:IF 2048&&v%:b%=1:IF v%&&256:b%=16
2360  IF 1024&&~~v%:b%=b%*5:ELSE IF v%&&128:b%=b%*4
2370  IF 512&&~~v%:b%=b%*3:ELSE IF v%&&64:b%=b%*2
2380  c%=v%&&63:xw%(c%)=xw%(c%)||b%:END DEFine
2390 :
2400 REMark We construct a string in wds$ to optimise sharing of words.
2410 REMark Each word needed is stored as four octal digits.
2420 REMark These are the two ACS pattern parts and the QL row and column.
2430 REMark Each type 2 or 3 entry will have a comma between two octal
2440 REMark  entries, i.e. the primary is prefixed with a comma.
2450 REMark A run of entries is postfixed with a space.
2460 REMark The first octal code in a run greater than one entry may be
2470 REMark  prefixed with either B (type 2 U/S) or C (type 3 Num)
2480 REMark  to show it is not yet fully determined.
2490 REMark Once the first code has been locked to provide a single, its
2500 REMark  letter is changed to A.
2510 REMark First insert type 3 double word entries (fixed prior bit 9).
2520 REMark Next insert type 2 double word entries (flexible prior bit 9).
2530 REMark Finally insert type 1 single word entries and special NumLock.
2540 REMark The optimal packing is rather difficult to establish.
2550 REMark We'll just go for near optimal.
2560 :
2570 DEFine FuNction insertpass%:LOCal b%,c%,e%,j%,k%,j,k
2580  LOCal w0$:wds$=' A':REMark Clever & avoid pre-Minnie string slices.
2590  FOR k=3,2,1
2600   k%=k
2610   FOR j=mf3min%TO mf3max%
2620    j%=j:b%=scw%(j%,0):IF b%DIV 4096=k%AND kat%(j%)+p%
2630     IF b%&&63:b%=b%^^3584:ELSE b%=0
2640     w0$=(b%DIV 512&&7)&(b%DIV 64&&7)&(b%DIV 8&&7)&(b%&&7)
2650     IF k%>1:insertpair:ELSE insertsingle
2660     END IF :END FOR j:END FOR k
2670  w0$='0000':insertsingle:REMark ensure NumLock is catered for
2680  REMark If we have a directly accessed word first, we try to replace
2690  REMark  it with a non-accessed word to squeeze an extra table entry.
2700  b%='B'INSTR wds$:IF NOT b%:b%='C'INSTR wds$
2710  IF b%:d%=' 'INSTR wds$(b%TO)+b%:wds$(2TO d%)=wds$(b%TO d%)&wds$(1TO b%-2)
2720  c%=1:d%=1:e%=LEN(wds$)-1:REMark Remove ABC chars no longer wanted
2730  REPeat lp:c%=(wds$(c%)=' ')+c%+5:d%=d%+5:wds$(d%-4TO d%)=wds$(c%-4TO c%):IF c%=e%:EXIT lp
2740  wds$=wds$(1TO d%-1):d%=d%DIV 5:c%=d%-58:IF b%:c%=c%-1:wds$(1)='x'
2750  REMark We have left ',' between pairs and ' ' before first/singles
2760  REMark If the first entry is not directly accessed we've avoided matching it as a single
2770  t$='The table overflowed by '&c%&' word'&FILL$('s',c%>1)&'.'
2780  RETurn c%>0:END DEFine
2790 :
2800 DEFine PROCedure insertsingle:LOCal b%
2810  IF w0$(1TO 2)&'.'INSTR'70.61.52.':RETurn :REMark simplest
2820  IF 'A'&w0$INSTR wds$:RETurn :REMark already there
2830  b%='B'&w0$INSTR wds$:IF NOT b%:b%='C'&w0$INSTR wds$:IF NOT b%:IF w0$(1)&&1:b%='C'&(w0$(1)-1)&w0$(2TO)INSTR wds$
2840  IF b%:wds$(b%TO b%+4)='A'&w0$:RETurn
2850  wds$=wds$&w0$&' A':END DEFine
2860 :
2870 DEFine PROCedure insertpair:LOCal b%,w1$,c%,d%
2880  w0$(1)=(k%=2)||w0$(1)&&6
2890  b%=scw%(j%,1):IF NOT b%MOD 64:b%=0:ELSE b%=b%^^3584:IF k%=2:IF b%&&512:b%=b%^^576:REMark change to standard
2900  w1$=(b%DIV 512&&7)&(b%DIV 64&&7)&(b%DIV 8&&7)&(b%&&7)
2910  IF w1$&','&w0$INSTR wds$:RETurn :REMark Already there
2920  d%=w1$&' 'INSTR wds$:IF NOT d%:IF k%=2:d%=(w1$(1)+1)&w1$(2TO)&' 'INSTR wds$
2930  IF d%
2940   c%='C'&w0$INSTR wds$:IF c%:IF joinok%:RETurn
2950   c%='B'&w0$INSTR wds$:IF NOT c%:IF k%=2:c%='B'&(w0$(1)-1)&w0$(2TO)INSTR wds$
2960   IF c%:IF joinok%:RETurn
2970   END IF
2980  c%='C'&w0$INSTR wds$:IF NOT c%
2990   d%=w1$&' 'INSTR wds$:IF NOT d%:IF k%=2:d%=(w1$(1)+1)&w1$(2TO)&' 'INSTR wds$
3000   IF d%:wds$=wds$(1TO d%+3)&','&w0$&wds$(d%+4TO):RETurn
3010   c%='B'&w0$INSTR wds$:END IF :IF c%:wds$=wds$(1TO c%-1)&CHR$(64+k%)&w1$&','&w0$&wds$(c%+5TO):RETurn
3020  wds$=' '&CHR$(64+k%)&w1$&','&w0$&wds$:END DEFine
3030 :
3040 DEFine FuNction joinok%:LOCal lp,e%,f%:REPeat lp
3050   IF c%>d%:EXIT lp
3060   IF ' 'INSTR wds$(c%TO)+c%<d%:EXIT lp
3070   REMark We must avoid case of trying to loop a run back onto itself!
3080   f%=w1$&' 'INSTR wds$(d%+1TO):IF NOT f%:IF k%=2:f%=(w1$(1)+1)&w1$(2TO)&' 'INSTR wds$(d%+1TO)
3090   IF f%:d%=d%+f%:EXIT lp
3100   e%=wds$(c%TO c%+5)INSTR wds$(c%+1TO)
3110   IF NOT e%:IF k%=2:IF wds$(c%+1)&&1:e%=wds$(c%)&(wds$(c%+1)-1)&wds$(c%+2TO c%+4)INSTR wds$(c%+1TO)
3115   IF NOT e%:RETurn 0
3120   c%=c%+e%:END REPeat lp:e%=' 'INSTR wds$(c%+1TO)+c%
3130  IF c%>d%:wds$=wds$(1TO d%+3)&','&w0$&wds$(c%+5TO e%)&wds$(d%+5TO c%-1)&wds$(e%+1TO):RETurn 1
3140  wds$=wds$(1TO c%-1)&wds$(e%+1TO d%+3)&','&w0$&wds$(c%+5TO e%)&wds$(d%+5TO):RETurn 1:END DEFine
3150 :
3160 DEFine FuNction vect%:LOCal b%,w0$,k%,e%
3170  b%=scw%(j%,0):IF NOT b%:RETurn 0
3180  IF b%=1:IF scw%(j%,1)<6:RETurn scw%(j%,1)+250
3190  IF NOT kat%(j%)+p%:RETurn 0
3200  IF b%MOD 64>1:b%=b%^^3584:ELSE b%=0
3210  w0$=(b%DIV 512&&7)&(b%DIV 64&&7)&(b%DIV 8&&7)&(b%&&7)
3220  k%=b%DIV 4096:IF k%<2
3230   e%=w0$(1TO 2)&'.'INSTR'70.61.52.':IF e%:RETurn e%DIV 3*64+b%MOD 64
3240   RETurn ' '&w0$INSTR wds$DIV 5+250-d%:END IF
3250  w0$(1)=(k%=2)||w0$(1)&&6
3260  b%=scw%(j%,1):IF b%MOD 64:b%=b%^^3584:IF k%=2:IF b%&&512:b%=b%^^576:REMark change to standard
3270  w0$=(b%DIV 512&&7)&(b%DIV 64&&7)&(b%DIV 8&&7)&(b%&&7)&','&w0$
3280  e%=w0$INSTR wds$:IF NOT e%:w0$(1)=w0$(1)^^1:e%=w0$INSTR wds$
3290  RETurn e%DIV 5+251-d%:END DEFine
3300 :
3310 DEFine PROCedure pleasewait$(a$):say2$a$,'Please wait.':END DEFine
3320 :
3330 DEFine PROCedure say1$(a$):say2$a$,'':END DEFine
3340 :
3350 DEFine PROCedure say2$(a$,b$):CLS#0:PRINT#0;\TO 40-LEN(a$)DIV 2;a$:AT#0;3,40-LEN(b$)DIV 2:PRINT#0;b$;:END DEFine
3360 :
3370 DEFine PROCedure init:LOCal j%,j,s,lp,a$
3380  Minnie%=PEEK(0):sv=163840:IF Minnie%:sv=VER$(-2):Minnie%=VER$(1)(1)&VER$(1)(3TO)
3390  hsh=sv+56:hsh$='HSH%':s=0:FOR j=1TO 4:s=s*256+CODE(hsh$(j))
3400  REPeat lp:hsh=PEEK_L(hsh):IF NOT hsh:EXIT lp:ELSE IF PEEK_L(hsh+58)=s:EXIT lp
3410  hx$='0123456789ABCDEF':bsrl%=24832:rts%=20085
3420  WINDOW 480,200,16,16:PAPER 2:INK 4:CLS
3430  WINDOW#0;480,40,16,216:PAPER#0;0:INK#0;4:CLS#0
3440  w%=20:h%=16:ikx0%=10:iky0%=6:rows%=11:cols%=22:ik%=rows%*cols%-1
3450  DIM iksc%(ik%),iky%(ik%),ike%(ik%),ikw%(ik%),ikf%(ik%)
3460  mf3min%=1:mf3max%=132:mf3len%=mf3max%+1-mf3min%
3470  DIM scw%(mf3max%,1),kat%(255),ibmshf%(6),bit%(13):RESTORE
3480  FOR j=0TO 13:j%=j:bit%(j%)=2^j%
3490  REPeat lp:READ a$:IF a$='':EXIT lp
3500  key%=0:do%=0:selshift%=0:high$='':END DEFine
3510 :
3520 DEFine PROCedure readlayout:LOCal x%,y%,row%,s%,t%,p%
3530  LOCal y0%,y1%,w0%,w1%,cx%,cy%,cw%
3540  LOCal lrud%,j%,j,k,a$
3550  FOR j=0TO ik%
3560   j%=j:IF NOT j%MOD cols%:x%=ikx0%:row%=j%DIV cols%:y%=((row%>4)*2+(row%>5)+row%*4)*h%DIV 4+iky0%
3570   IF j%=cols%*6-4:y%=y%-h%DIV 8
3580   READ a$:IF '+'INSTR a$=1:x%=x%+a$(2TO)*w%:READ a$
3590   s%=' 'INSTR a$:IF s%
3600    s%=a$(1)INSTR hx$-1:t%=a$(2)INSTR hx$-1:IF row%<5:s%=s%*8+t%^^192:ELSE s%=s%*16+t%
3610    iksc%(j%)=s%:kat%(s%)=j%:a$=a$(3TO):ELSE a$=a$&' ':END IF
3620   w1%=w%:lrud%=((7*4+2)*4+1)*4
3630   REPeat lp
3640    p%=a$(1)INSTR'lrudwt'-1:IF p%<0:EXIT lp
3650    IF p%=4:w1%=w%*a$(2TO):EXIT lp
3660    IF p%=5:ikf%(j%)=1:ikf%(j%+cols%)=2:a$=a$(2TO):NEXT lp
3670    p%=4^p%:lrud%=lrud%&&~~(3*p%)||(a$(2)INSTR'lrud'-1)*p%
3680    a$=a$(3TO):END REPeat lp
3690   x%=x%+w1%:ike%(j%)=x%:iky%(j%)=y%:ikw%(j%)=w1%:IF NOT s%:IF NOT ikf%(j%):ikf%(j%)=lrud%
3700   IF s%
3710    y0%=y%:y1%=y%+h%:w0%=w1%:cw%=w1%:IF ikf%(j%)=2:w0%=ikw%(j%-cols%):IF w0%>=w1%:y0%=y%-h%:IF w0%>w1%:y1%=y%:cw%=w0%
3720    a$=a$(' 'INSTR a$+1TO):cx%=x%-cw%DIV 2:cy%=(y0%+y1%)DIV 2
3730    s%=' 'INSTR a$:IF s%:cent$cx%,cy%-4,a$(1TO s%-1):cent$cx%,cy%+3,a$(s%+1TO):ELSE cent$cx%,cy%,a$
3740    IF w0%<>w1%
3750     BLOCK 1,h%*2+1,x%,y%-h%,0
3760     ELSE
3770     FOR k=y0%,y1%:BLOCK w1%+1,1,x%-w1%,k,0
3780     FOR k=x%-w0%,x%:BLOCK 1,y1%-y0%+1,k,y0%,0
3790     END IF :END IF :END FOR j:END DEFine
3800 :
3810 DEFine PROCedure cent$(x%,y%,t$):CURSOR x%-LEN(t$)*3,y%-4:OVER 1:PRINT t$:OVER 0:END DEFine
3820 :
3830 DEFine PROCedure readtranslate:LOCal w0%,w1%,c%
3840  LOCal j%,j,s,lp,a$
3850  FOR j=mf3min%TO mf3max%
3860   j%=j:READ a$:w0%=0:w1%=0:IF a$<>''
3870    REPeat lp
3880     c%=a$(1)INSTR'~UNL~~R-+':s=c%:SELect s
3890     =0:w0%=((w0%<64)*64+w0%)*64+a$(1)*8+a$(2)
3900     =2,3:w1%=w0%&&4095:w0%=c%*64||8
3910     =4,7:w0%=1:w1%=a$(2)INSTR'SCAN'+c%-5:ibmshf%(w1%)=j%
3920     =REMAINDER :w0%=bit%(a$(2)INSTR'SCA'-1)*c%||w0%:END SELect
3930     IF LEN(a$)=2:EXIT lp
3940     a$=a$(3TO):END REPeat lp:END IF
3950   scw%(j%,0)=w0%:scw%(j%,1)=w1%:END FOR j
3960  REMark Find a complex key and show it (should be a wanderer)
3970  FOR s=2,3,1
3980   FOR j=mf3min%TO mf3max%:selibm%=j:q%=kat%(selibm%):IF q%:IF scw%(selibm%,0)DIV 4096=s:EXIT s
3990   END FOR s:q2%=q%:loadkey:context:END DEFine
4000 :
4010 DEFine PROCedure dohelp:LOCal a$,b$,i%,i,lp:CLS#0:READ b$:IF do%OR''=b$:RESTORE :READ b$
4020  REPeat lp:IF b$(LEN(b$))INSTR' \':READ a$:b$=b$&a$:ELSE EXIT lp
4030  REPeat lp
4040   i%='\'INSTR b$:IF i%>81OR NOT i%
4050    IF LEN(b$)<81:EXIT lp
4060    FOR i=81TO 1STEP -1:i%=i:IF b$(i%)=' ':EXIT i
4070    END IF :PRINT#0;b$(1TO i%-1):b$=b$(i%+1TO):END REPeat lp
4080   END REPeat lp:PRINT#0;b$TO 72;'F1: more':END DEFine
4090 :
5000 REMark Help data
5010 DATA 'The highlit QL keys are the effect of the highlit IBM key combination.\'
5020 DATA 'The top right area shows the type of translation currently being done.\'
5030 DATA 'The second (right hand) section is only active for complex keys.\'
5040 DATA 'The four boxes above the IBM keypad provide program actions.'
5050 DATA 'Translations can take on four basic types of increasing complexity.\'
5060 DATA 'At its simplest, an IBM key is mapped directly to a QL key, and any IBM shifts '
5070 DATA 'map directly to their corresponding QL shifts, plus either CTRL or SHIFT may be '
5080 DATA 'forced on, but not both. This is translation type "+=C/+=S".'
5090 DATA 'The next level of translation is for keys that are still only translated to a '
5100 DATA 'single QL key, but accompanying shifts are remapped in a more general way.\'
5110 DATA 'Each of ALT, CTRL and SHIFT may be preserved ("="), forced on ("+"), forced off '
5120 DATA '("-") or inverted ("~"), giving us translation type "ACS".'
5130 DATA 'At its next most complicated, an IBM key may translate to one key when it is not '
5140 DATA 'SHIFTed (left pattern) and a distinct QL key when it is SHIFTed (right pattern).\'
5150 DATA 'To make things clearer, the SHIFT columns are forced to show only "+S" or "-S".\'
5160 DATA 'This type of translation is selected by "U/S".'
5170 DATA 'At its most complicated, we have an IBM key that is to be sensitive to NumLock.\'
5180 DATA 'The left pattern is used only when the key is NumLocked and not SHIFTed.\'
5190 DATA 'As the right pattern applies whenever NumLock is not set, all those SHIFT column '
5200 DATA 'options are kept available. This is translation type "Num".'
5210 DATA 'In all cases, the "X" box may be checked to indicate that the IBM key, in the '
5220 DATA 'particular SHIFT/NumLock state, is completely ignored. When an "X" is highlit, '
5230 DATA 'the corresponding pattern area will have nothing highlit.\'
5240 DATA 'Changing translations forces IBM SHIFT and/or NumLock appropriately.'
5250 DATA 'F4 and F5 are shortcuts, toggling the IBM SHIFT and NumLock respectively.\'
5260 DATA 'F3 tries to produce an ammended file as "IPCEXTS_NEW".\'
5270 DATA 'F2 loads the full translation table from the current "IPCEXTS_BIN" file.\'
5280 DATA 'Use     to move around, space/enter/do to action.'
5290 DATA 'Actions in the IBM keyboard area:\'
5300 DATA 'General IBM keys select that key and show its translation type and QL effect.\'
5310 DATA 'IBM shift keys and NumLock toggle that key and update the QL effect.\'
5320 DATA 'F4 and F5 may also be used to toggle the IBM SHIFT or NumLock.'
5330 DATA 'Actions in the QL keyboard area:\'
5340 DATA 'General QL keys make the current IBM key pattern map to that key.\'
5350 DATA 'QL shift keys invert the corresponding IBM shift effect.\'
5360 DATA 'Note that only the right QL SHIFT key is ever highlit.'
5370 DATA 'Actions on the right hand six keys of the top row:\'
5380 DATA 'The "X" boxes make the IBM key have no corresponding QL effect.\'
5390 DATA 'The "=+S/=+C" or "ACS" makes only the first pattern active, for simpler keys.\'
5400 DATA 'The "U/S" or "Num" activates the second pattern for the complex keys.'
5410 DATA 'Action in first pattern section:\'
5420 DATA 'Select "=" to duplicate, "-" to force off, "+" to force on or "~" to invert.\'
5430 DATA 'This sets the effect of ALT/CTRL/SHIFT for a simple QL key, '
5440 DATA 'unSHIFTed "U/S" key or unSHIFTed Num key with NumLock active.'
5450 DATA 'Action in second pattern section:\'
5460 DATA 'This forces the key to be complex and sets the SHIFTed or un-NumLocked effect.\'
5470 DATA 'If the key was simple, "U/S" is selected and the IBM SHIFT is forced on.\'
5480 DATA 'If the key was "Num" and IBM SHIFT is off, NumLock is cleared.'
5490 DATA 'Action on four keys above IBM keypad:\'
5500 DATA 'Space "???" (or F1) does this. "End" (or ESC) to exit.\'
5510 DATA 'Space "Get" (or F2) to load mapping from the current "'&fbin$&'".\'
5520 DATA 'Space "Put" (or F3) to attempt to store new mapping as "'&fnew$&'".'
5530 DATA 'Generally, space and enter are synonymous, and shifts are ignored, except:\'
5540 DATA 'Enter "???" (or SHIFT/F1) restarts this help.\'
5550 DATA 'Enter "Get" (or SHIFT/F2) to load mapping from a specified file.\'
5560 DATA 'Enter "Put" (or SHIFT/F3) to store mapping using specified files.'
5570 DATA 'Mappings that go to a single QL key, and simply force SHIFT (=A/=C/+S), simply '
5580 DATA 'force CTRL (=A/+C/=S) or leave all shifts unchanged (=A/=C/=S) take up no table '
5590 DATA 'space, whereas more complex mappings use at least one word of a 58 word table.\'
5600 DATA 'The "U/S" and "Num" translation types use a pair of words.'
5610 DATA 'Before storing the table, attempts to share or reuse words are made. E.g. the '
5620 DATA 'standard keypad key "9/PgUp" stores two words, but the "Page Up" key will share '
5630 DATA 'one of those words. One extra word is also usually squeezed in, when there is at '
5640 DATA 'least one pair whose second word is not shared.'
5650 DATA 'The DATA statements in this program may be modified to accomodate different '
5660 DATA 'keyboards. The default translation table has extra entries that allow it to work '
5670 DATA 'with a variety of IBM keyboards. On a "Put", if the translation table overflows, '
5680 DATA 'this program retries, omitting scan codes that are not used.'
5690 DATA 'A facility for modifying the default translations:\'
5700 DATA 'To allow the DATA statements to be easily ammended:\'
5710 DATA ' CTRL/F2 will create a file of the required DATA statements.\'
5720 DATA ' CTRL/SHIFT/F2 allows the file name to be edited.'
5730 DATA 'Yet another twiddle... there are actually TWO cursors. You may toggle between '
5740 DATA 'them with the TAB key.\'
5750 DATA ' \','End of help.',''
5760 :
8180 :
8190 REMark Dump DATA statements as per the above formats
8200 DEFine PROCedure dumpkdef:LOCal lp,s,j,j%,k%,l%,t$,w0%,w1%,t%
8210  IF do%:prompt$'Create DATA name',fdat$
8220  pleasewait$'Creating '&fdat$:DELETE fdat$:OPEN_NEW#4;fdat$
8230  l%=8000:t$=''
8240  FOR j=mf3min%TO mf3max%
8250   j%=j:w0%=scw%(j%,0):IF w0%
8260    w1%=scw%(j%,1):IF w0%=1
8270     w0%=w1%>2:t$=t$&'LR'(w0%+1)&'SCAN'(w1%+1-3*w0%)
8280     ELSE
8290     t%=w0%DIV 4096:IF t%>1
8300      IF w0%&&64:w0%=w0%||512:ELSE w0%=w0%&&-513
8310      IF t%=2:IF w1%&&64:w1%=w1%||512:ELSE w1%=w1%&&-513
8320      END IF :REPeat lp
8330      IF t%<2:w1%=w0%
8340      IF w1%&&63
8350       k%=w1%DIV 64&&63
8360       FOR s=1TO 3:k%=k%*2:IF k%&&72:t$=t$&'~      -+'(k%DIV 8&&9)&'ACS'(s)
8370       END IF :t$=t$&(w1%DIV 8&&7)&(w1%&&7):IF t%<2:EXIT lp
8380      IF t%=2:t$=t$&'US':ELSE t$=t$&'NL'
8390      t%=0:END REPeat lp
8400     END IF :END IF :IF j%MOD 8<7AND j%<mf3max%:t$=t$&"','":NEXT j
8410   l%=l%+10:PRINT#4;l%;" DATA '"&t$&"'":t$='':END FOR j
8420  CLOSE#4:say1$'Created '&fdat$:END DEFine
8430 :
9000 REMark Help data format
9010 REMark At each call of the help routine, data items are read and
9020 REMark concatenated until the final character is not a "\" or space.
9030 REMark Wherever there is a "\", a line break is forced.
9040 REMark The rest of the string is split into 80 character maximum
9050 REMark chunks at spaces.
9060 REMark At the end of all that, there should be four lines to print,
9070 REMark with the last leaving room for the "F1: more".
9080 REMark The end of the help data is marked with a null string.
9090 :
9100 REMark QL/control/IBM data format
9110 REMark This enables the screen to be drawn, and sets up internal
9120 REMark  codes for each box.
9130 REMark Generally, there is precisely one data item per element of a
9140 REMark  22 column by 11 row grid.
9150 REMark In order to leave horizontal gaps, an extra data item with a
9160 REMark  "+" prefix is used.
9170 REMark All other items describe elements of the grid.
9180 REMark Items that describe real boxes contain at least one space and
9190 REMark  start with a two digit code.
9200 REMark Items that are "place holders" for elements of the grid have a
9210 REMark  "navigation" prefix.
9220 REMark The navigation prefix is 0..4 pairs of characters saying that,
9230 REMark  when the cursor gets here travelling in a given direction,
9240 REMark  which way to go next.
9250 REMark By default, the prefix is taken to read "llrruudd", i.e.
9260 REMark  travel straight through.
9270 REMark For tall keys, the element corresponding to the top part of
9280 REMark  the key has a "t".
9290 REMark For elements whose width is not standard, a number prefixed
9300 REMark  with "w" says how wide.
9310 REMark For the "real" items, the two digit code is interpretted in a
9320 REMark  funny old way:
9330 REMark For the first five rows, it is essentially the QL scan code.
9340 REMark The control box codes are wierd, and have a hex first digit!
9350 REMark The left QL "SHIFT" key is also recognised by a special code.
9360 REMark The remaining six rows are read as hex, and give the IBM MF3
9370 REMark  scan codes direct, or a control.
9380 REMark After the first space in a "real" item, there is the single,
9390 REMark  or upper, text to show on the key.
9400 REMark If there is another space, the text following that will be
9410 REMark  shown as the lower text.
9420 :
9430 REMark Default translation data
9440 REMark This gives the key efeect for each MF3 scan code in sequence.
9450 REMark Generally it is any shift adjustments and the QL scan code.
9460 REMark Shift adjustments are +, - or ~ with A, C or S.
9470 REMark "Complex" translations have a second code after "US" or "NL".
9480 REMark The second code is the unSHIFTed, unNumLocked effect.
9490 REMark For keys that are to be ignored, the QL code is zero.
9500 REMark I.e. for the numeric keypad 5, the second QL code is zero.
9510 REMark The IBM shift keys are shown as LA/LC/LS/RA/RC/RS.
9520 REMark The NumLock is also special, and is shown as RN.
9530 REMark Undefined MF3 codes are given as a null string.
9540 :
