10REM > Display   Weather Satellite image display program
   20REM (C) BBC tv  and  Peter Vince  22/2/89
   30 
   40*SAVE"a"0+5000
   50*DELETE"a"
   60 
   70ON ERROR ON ERROR OFF:PRINTTAB(0,28);:REPORT:GOTO610
   80DIM Z% 360, C%(8), code 72
   90PROCassemble
  100 
  110MODE7
  120*CAT
  130INPUT'"Enter name of file to be drawn ";infyl$
  140S%=OPENINinfyl$
  150IF S%=0 THEN PRINT"Data file """;infyl$;""" not found.";CHR$7:END
  160 
  170PTR#S%=2
  180IF BGET#S%<3 OR BGET#S%-&84 OR BGET#S%-16 THEN format=FALSE ELSE format=TRUE
  190width=BGET#S% + BGET#S%*256
  200height=BGET#S% + BGET#S%*256
  210IF (width=276 AND height=200) OR (width=320 AND height=256) OR (width=360 AND height=288) THEN size=TRUE ELSE size=FALSE
  220PTR#S%=17
  230IF format=FALSE OR size=FALSE OR (BGET#S%AND7)-3 THEN PRINT'"Data using incompatible format -"'"cannot decode."';CHR$7:CLOSE#S%:END
  240 
  250message%=BGET#S%
  260IF message% AND 1 THEN ident$=FNgetstring  ELSE GOTO290
  270IF message% AND 16 THEN PRINT'new$
  280 
  290creditflag%=BGET#S%
  300IF creditflag% AND 1 THEN credit$=FNgetstring  ELSE credit$="" : GOTO330
  310IF creditflag% AND 16 THEN PRINT'new$
  320 
  330IF ((message% OR creditflag%) AND 16) = 0 THEN 370
  340PRINT'"Press the Space-Bar to continue...";
  350REPEAT UNTIL GET=32
  360 
  370MODE2
  380VDU23,1,0;0;0;0;
  390COLOUR 132:CLS
  400IF (width=276 AND height=200) THEN window=TRUE ELSE window=FALSE : GOTO430
  410VDU 24,72;96;1207;927; :GCOL0,134:CLG
  420VDU 24,88;112;1191;911;:GCOL0,132:CLG:VDU26
  430PROCcaptions
  440 
  450REM Define colours for 'grey scale'
  460C%(0)=0:C%(1)=4:C%(2)=1:C%(3)=5:C%(4)=2:C%(5)=6:C%(6)=3:C%(7)=7:C%(8)=7
  470PTR#S%=0 : PTR#S% = BGET#S% + BGET#S%*256
  480 
  490FOR V% = (0-window*112) TO (1020+window*112) STEP 4
  500MOVE (1280+window*88),V%
  510PROCfill
  520FOR I%=P% TO (360+window*80) : Z%?I%=C% : NEXT
  530FOR P%=0 TO (319+window*44) STEP 2
  540GCOL0,C%((Z%?P%+Z%?(P%+1)+2)DIV4)
  550PLOT65,-8,0
  560NEXT
  570NEXT
  580 
  590OSCLI("SAVE "+outfyl$+" FFFF3000+5000 0")
  600PRINTTAB(1,30)" Saved as ";outfyl$;" "
  610VDU23,1,1;0;0;0; 31,0,31
  620CLOSE#0
  630*FX20
  640END
  650 
  660DEFPROCfill
  670B%=&FF:P%=0
  680REPEAT
  690O%=B%
  700B%=BGET#S%
  710C%=B%AND15
  720W%=B%DIV16
  730IF C%=O% THEN UNTIL TRUE : ENDPROC
  740IF W%=15 THEN W%=BGET#S%+15 : IF W%=270 THEN W%=BGET#S%+270
  750FOR P%=P% TO P%+W% : Z%?P%=C% : NEXT
  760UNTIL FALSE
  770 
  780DEFPROCcaptions
  790PROCredef
  800GCOL0,7:GCOL0,132
  810source$=FNgetstring
  820rad%=BGET#S%
  830date$=FNgetstring
  840time$=FNgetstring
  850 
  860IF (message%AND12)=0 THEN 1020
  870IF (message%AND3)<>3 THEN ident$=source$
  880title$=""
  890FOR I%=1 TO LEN(ident$)
  900C%=ASC(MID$(ident$,I%,1))
  910IF C%>96 AND C%<123 THEN C%=C% AND &DF
  920title$=title$+CHR$C%
  930NEXT
  940IF message%AND2 THEN 990
  950 
  960IF rad%>0 AND rad%<5 THEN title$=title$+" "+MID$(" IRVZWVRD",rad%*2,2)
  970IF date$<>"" THEN title$=title$+"  "+LEFT$(date$,2)+"/"+MID$(date$,3,2)+"/"+MID$(date$,5)
  980IF time$<>"" THEN title$=title$+" "+LEFT$(time$,2)+":"+MID$(time$,3)
  990MOVE 640-LEN(title$)*16,924+window*864
 1000PROCnarrow
 1010 
 1020IF credit$="" OR (creditflag%AND7)<>7 THEN 1120
 1030title$=""
 1040FOR I%=1 TO LEN(credit$)
 1050C%=ASC(MID$(credit$,I%,1))
 1060IF C%>96 AND C%<123 THEN C%=C% AND &DF
 1070title$=title$+CHR$C%
 1080NEXT
 1090MOVE 640-LEN(title$)*16,988
 1100PROCnarrow
 1110 
 1120jd$=FNgetstring
 1130IF jd$="" THEN outfyl$="NODATE" : GOTO1180
 1140A%=0 : Y%=0 : F%=USR(&FFDA)AND&FF : REM Find filing system for name length
 1150IF F%=4 THEN outfyl$=MID$(jd$,4,4) ELSE outfyl$=LEFT$(jd$,7)
 1160outfyl$=outfyl$+MID$(jd$,9,2)
 1170 
 1180area=BGET#S% AND &7F
 1190IF area>0 AND area<5 THEN prefix$=MID$("waeb",area,1) ELSE prefix$="?"
 1200outfyl$=prefix$+outfyl$
 1210 
 1220VDU23,1,0;0;0;0;
 1230ENDPROC
 1240 
 1250DEFFNgetstring
 1260new$=""
 1270REPEAT
 1280C%=BGET#S%
 1290IF C% THEN new$=new$+CHR$C%
 1300UNTIL C%=0
 1310=new$
 1320 
 1330DEFPROCnarrow
 1340IF LEN(title$)>38 THEN title$=LEFT$(title$,38)
 1350VDU 5
 1360FOR I%=1 TO LENtitle$
 1370A%=ASC(MID$(title$,I%,1))
 1380CALL code
 1390NEXT
 1400VDU 4
 1410ENDPROC
 1420 
 1430DEFPROCredef
 1440REM Redefine characters to look better when squashed
 1450IF PAGE>&E00 THEN lim=8 ELSE lim=16:*FX20,6
 1460RESTORE 1530
 1470FOR I%=1 TO lim
 1480READ C$:VDU23,ASC C$
 1490FOR J%=1 TO 7:READ B$:VDU EVAL("&"+B$):NEXT
 1500VDU 0:NEXT
 1510ENDPROC
 1520 
 1530DATA 0,1C,36,63,63,63,36,1C, 2,1C,66,06,0C,18,30,7E
 1540DATA 3,1C,66,06,1C,06,66,1C, 5,7E,60,7C,06,06,66,1C
 1550DATA 6,1C,30,60,7C,66,66,1C, 8,1C,66,66,1C,66,66,1C
 1560DATA 9,1C,66,66,1E,06,06,18, /,00,03,06,0C,18,30,60
 1570DATA A,1C,66,66,7E,66,66,66, C,1C,66,60,60,60,66,1C
 1580DATA D,78,66,66,66,66,66,78, M,63,7F,7F,6B,63,63,63
 1590DATA O,1C,66,66,66,66,66,1C, S,1C,66,60,1C,06,66,1C
 1600DATA U,66,66,66,66,66,66,1C, Y,66,66,66,3E,18,18,18
 1610 
 1620DEFPROCassemble
 1630FOR V%=0 TO 2 STEP 2
 1640P%=code
 1650[ OPT V%
 1660 STA block
 1670 LDX #(block MOD 256)
 1680 LDY #(block DIV 256)
 1690 LDA #10 :JSR &FFF1
 1700 
 1710 LDX #8
 1720.loop1
 1730 LDA #0 :LDY #4
 1740.loop2
 1750 LSR block,X :LSR block,X :ROR A
 1760 DEY :BNE loop2
 1770 STA block,X
 1780 DEX :BNE loop1
 1790 
 1800 LDA #23 :JSR &FFEE
 1810 LDA #255:JSR &FFEE
 1820.loop3
 1830 LDA block+1,X :JSR &FFEE
 1840 INX
 1850 CPX #15 :BNE loop3
 1860 RTS
 1870 
 1880.block
 1890 EQUB 0 :EQUD 0 :EQUD 0
 1900 EQUB 255
 1910 EQUB 25 :EQUB 0 :EQUW -32 :EQUW 0
 1920]
 1930NEXT
 1940ENDPROC