0010 ! HP-41 barcode with an HP-71 version A
0020 ! Michael Markov
0030 ! See BAR75C, CHHU Chronicle V3N1P16 for documentation
0040 ! 
0050 ! Uses BINLEX by M.Markov, to speed-up the programs. Uses also the
0060 ! REPLACE$ keyword to convert the barcode row bit pattern to a graphic
0070 ! string. REPLACE$ is available in JPCLEX. See also CHHU05 swapdisk
0080 ! REPLEXS, or CCV2N7. BINLEX is still in development at this time, see
0090 ! BINLEX4S for latest version, ATBIN$ keyword.
0100 ! 
0110 ! Eventually, with plenty of RAM, ATBIN$ & BTA$ will allow us to control
0120 ! the width of barcode bars in row graphic (HP) mode exactly as on EPSON
0130 ! printers. This could also facilitate LaserJet (or other) versions 
0140 ! with very high resolution capability, thus permitting super-compact
0150 ! barcode. Whenever somebody else does it: I do not have a LaserJet...
0160 ! 
0170 ! Uses the "KEYWAIT", "STRINGLX", "DIRLEX" & "PILEXTL4" LEX files.
0180 ! DIRLEX was posted on the CHHU BBS. It can be replaced by HEXLEX7,
0190 ! which is available on the CHHU04 swapdisk.
0200 ! The TAPESTAT keyword from J.R. Baker's PILEXTL4 file can be replaced
0210 ! with WAIT 50. This gives a tape or disk drive time to position the
0220 ! read head to any target sector. Alternatively, you could use SPOLL
0230 ! to determine whether the drive is still busy....
0240 ! 
0250 ! The powerfull syntax of the HP71 HPIL ROM allows the following
0260 ! responses to the prompt "Filename? ":
0270 !    --  "aBURN41"
0280 !    --  " aBURN41:TAPE(2)"
0290 !    --  "aBURN41:3:2" 
0300 ! If no device specifier is given, "TAPE(1):1" is used as a default.
0310 ! This program supports multi-loop operations.
0320 ! 
0330 DESTROY ALL @ DIM A$[32],F$[32]
0340 H5=0
0350 INPUT "Bytes/Row? ","13";R6 @ R6=MAX(MIN(13,R6-3),1)
0360 INPUT "Rows/Pg, Row Height? ","24,26";H6,H7
0370 IF H5 THEN 910 ELSE H=0 @ H8=0 @ H9=0 @ LC OFF
0380 PWIDTH INF @ DIM O$[1290]
0390 INPUT "Hp or Epson printer? ","H";Q$ @ H8="H"=UPRC$(Q$)
0400 IF NOT H8 THEN O1$=RPT$(CHR$(255),7)&RPT$(CHR$(0),5) @ O0$=O1$[5]
0410 INPUT "Filename? ";F$
0420 P=POS(F$,":") @ IF NOT P THEN F$=RTRIM$(F$)&":TAPE:1" @ GOTO 420
0430 D$=UPRC$(F$[P]) @ D=DEVADDR(D$)
0440 L=POS(F$,":",P+1) @ IF L THEN L=VAL(F$[L+1]) ELSE L=1
0450 F$=F$[1,P-1] @ F$[11]=CHR$(224)&CHR$(128)
0460 SEND L; UNT UNL MTA LISTEN D DDL 4 DATA 0,2 UNL 
0470 TAPESTAT :D:L
0480 SEND L; UNL UNT TALK D DDT 2 
0490 ENTER :D:L USING "#,32A";A$
0500 IF NUM(A$)=255 THEN DISP "File not found" @ BEEP @ END 
0510 IF POS(A$,F$)#1 THEN 490
0520 SEND L; UNT MTA LISTEN D DDL 4 DATA A$[15,16] UNL 
0530 L0=NUM(A$[29])*256+NUM(A$[30]) @ DIM P$[L0]
0540 P9=BINAND(NUM(A$[31]),1) ! Privacy bit set if P=1
0550 STD @ M$="#,"&STR$(L0)&"A"
0560 TAPESTAT :D:L
0570 SEND L; TALK D DDT 2 @ ENTER :D:L USING M$;P$
0580 SEND L; UNT UNL LISTEN D SDC UNL 
0590 ! P$ now holds the selected HP-41 program.
0600 P$[L0]=CHR$(47) @ GOTO 910 ! Barcode specs.
0610 B=NUM(P$[R0]) @ B1=NUM(P$[R0+1]) @ B2=NUM(P$[R0+2])
0620 X=1+(B>143)+(B>207)
0630 IF B>239 THEN X=B-239
0640 IF B>28 AND B<32 THEN X=MAX(2,B1-238)
0650 IF B>191 AND B<206 AND B2>240 THEN X=B2-237
0660 IF B>191 AND B<206 AND B2<241 THEN X=3
0670 IF B>15 AND B<29 THEN GOSUB 690
0680 L2=L2+(B#0) @ R0=R0+X @ RETURN 
0690 N=R0+1
0700 B9=NUM(P$[N,N]) @ N=N+1
0710 IF B9>15 AND B9<29 THEN X=X+1 @ GOTO 700 ELSE RETURN 
0720 IF H8 THEN PRINT HEXTOA$('0E1B')&'&l8D'; ELSE PRINT HEXTOA$('1B301B45');
0730 PRINT F$[1,10];L0;'Bytes'
0740 H5=1 @ L2=1 @ L1=1 @ R0=1 @ M1=0 @ M2=0 @ C=0 @ T=16*(1+P9)
0750 IF H8 THEN PRINT CHR$(27)&'*r1280S';
0760 FOR I=1 TO L0 STEP R6 @ E=MIN(L0,I+R6-1) @ B$=P$[I,E]
0770 M1=MIN(R6,R0-I)
0780 IF R0<E+1 THEN GOSUB 610 @ GOTO 780
0790 M2=(X+E-R0+1)*(E+1#R0) @ R=CEIL(I/R6)
0800 B$=CHR$(T+MOD(R-1,16))&CHR$(M1*16+M2)&B$
0810 FOR K=1 TO LEN(B$) @ C=C+NUM(B$[K,K])
0820 C=MOD(C+INT(C/256),256) @ NEXT K
0830 B$=CHR$(C)&B$
0840 IF R9 AND R<>R9 THEN 890
0850 IF H9 THEN H$=HEX$(B$) ELSE H$=""
0860 PRINT USING '"ROW ",3D,"   Lines",4D,"-",4D,3X,33A';R;L1;L2-1;H$
0870 GOSUB 970 @ IF R=R9 THEN 910
0880 IF NOT MOD(R,H6) THEN PRINT CHR$(12)
0890 L1=(R0=E+1)+L2-1
0900 NEXT I
0910 R9=0 @ DISP "End/All/Row/Hex ";
0920 IF H9 THEN DISP "off" ELSE DISP "on"
0930 ON POS("EARHM",UPRC$(KEYWAIT$))+1 GOTO 930,960,720,950,940,350
0940 H9=NOT H9 @ GOTO 910
0950 INPUT "Row #? ";R9 @ GOTO 740
0960 PWIDTH 80 @ END 
0970 IF NOT H8 THEN 1060
0980 O$="7070"&REPLACE$(REPLACE$(ATBIN$(B$),"0","70"),"1","7F0")&"7F07"
0990 IF MOD(LEN(O$),2) THEN O$=O$&'0'
1000 O$=HEXTOA$(O$)
1010 ENDLINE '' @ PRINT CHR$(27)&'*rA';
1020 FOR H=1 TO H7
1030 PRINT CHR$(27)&'*b'&STR$(LEN(O$))&'W'&O$;
1040 NEXT H @ PRINT RPT$(CHR$(27)&'*b1W'&CHR$(0),2);
1050 ENDLINE @ PRINT CHR$(27)&'*rB'; @ RETURN 
1060 O$=O0$&O0$ @ FOR A=1 TO LEN(B$)
1070 FOR A0=7 TO 0 STEP -1
1080 IF SBIT(B$,A,A0) THEN O$=O$&O1$ ELSE O$=O$&O0$
1090 NEXT A0 @ NEXT A @ O$=O$&O1$&O0$ @ C2=LEN(O$)
1100 PRINT HEXTOA$('0F1B4108');
1110 O$=HEXTOA$('1B4C')&CHR$(C2)&CHR$(C2/256)&O$
1120 FOR H=1 TO H7 DIV 8 @ PRINT O$ @ NEXT H @ PRINT HEXTOA$('1B4102')
1130 PRINT HEXTOA$('1B55301B30121B45'); @ RETURN