' THE TRACK 41 PROTECTOR
' (C) 1987 by Claus Brod
'             Am Felsenkeller 2
'             D-8772 Marktheidenfeld
'             Tel. (West Germany) 09391-3206
'
' Last update 28.9.87
' Installs a copy protection on a blank disk (track 41)
' Written exclusively for STNEWS
'
'
Ron$=Chr$(27)+"p"
Roff$=Chr$(27)+"q"
@Init
@Dispatch
End
' ************
' ****dispatch: shows menu and waits for choice
' ************
Procedure Dispatch
  Repeat
    Cls
    Print At(28,1);Ron$;"THE TRACK 41 PROTECTOR";Roff$
    Print At(28,2);"(C) 1987 by Claus Brod"
    Print At(28,5);"(0) Exit"
    Print At(28,6);"(1) Read Track 41 & Check"
    Print At(28,7);"(2) Write Track 41"
    Print At(28,8);"(3) Show Track Buffer"
    Repeat
      A$=Upper$(Input$(1))
    Until A$>="0" And A$<"4"
    Choice=Val(A$)
    On Choice Gosub Read,Write,Showtrk
  Until Choice=0
Return
'
' ***************
' ****** read: inputs password, reads track 41 into buffer
' ******       and looks for password
' ***************
Procedure Read
  Print
  Print Ron$;"Read Track 41";Roff$
  Line Input "Copyright string";Copy$
  Buf$=String$(8000,Chr$(0))
  @Rdtrk(Varptr(Buf$))
  A=Instr(Buf$,Copy$)
  If A=0
    Print "Copyright message not found"
  Else
    Print "Copyright message found at offset ";A
  Endif
  Void Inp(2)
Return
'
' **************
' ***** rdtrk: Reads track 41 from disk into buffer
' *****        (pointed to by pointer%)
' **************
Procedure Rdtrk(Pointer%)
  Prg%=Varptr(Prg$)                 ! start of machine code
  Lpoke Prg%+2,0                    ! mode 0 (read track)
  Lpoke Prg%+6,Pointer%             ! pointer to buffer (at least 7K please!)
  Call Prg%                         ! call mcode
Return
'
' *************
' ***** write: creates & writes track 41 from buffer including a password
' *************
Procedure Write
  Print
  Print Ron$;"Write Track 41";Roff$
  Line Input "Copyright string";Copy$
  @Mktrk(Copy$)
  @Wrtrk(Varptr(Buf$))
Return
'
' **************
' ****** wrtrk: writes track 41 from buffer pointed to by
' ******        pointer%
' **************
Procedure Wrtrk(Pointer%)
  Prg%=Varptr(Prg$)                      ! start of machine code
  Lpoke Prg%+2,1                         ! mode 1 (write track)
  Lpoke Prg%+6,Pointer%                  ! start of buffer containing track data
  Call Prg%                              ! call mcode
Return
'
' ***************
' ****** mktrk: constructs 9-sector track 41 with password c$
' ***************
Procedure Mktrk(C$)
  Sync$=Chr$(&HF5)+Chr$(&HF5)+Chr$(&HF5)  ! sync bytes
  Sec$=String$(512,Chr$(203))             ! sector data
  Gap1$=String$(60,Chr$(&H4E))            ! gap1
  Gap2$=String$(12,Chr$(0))               ! gap2
  Gap31$=String$(22,Chr$(&H4E))           ! gap31
  Gap32$=Gap2$                            ! gap32
  Gap4$=String$(40,Chr$(&H4E))            ! gap4
  Gap5$=String$(1401,Chr$(&H4E))          ! gap5
  Mid$(Gap1$,3)=Chr$(&H29)+Chr$(&HF5)     ! syncs into gap1
  Print "Password is ";C$                 ! print password again
  Mid$(Gap1$,5)=C$                        ! password to gap1
  '
  Buf$=Gap1$                              ! start of buf$
  For T=1 To 9
    Buf$=Buf$+Gap2$+Sync$+Chr$(&HFE)+Chr$(41)+Chr$(0)+Chr$(T)+Chr$(2)
    ' start of sector, address header
    Buf$=Buf$+Chr$(&HF7)
    ' checksum
    Buf$=Buf$+Gap31$+Gap32$+Sync$+Chr$(&HFB)
    ' gap before data and data mark
    Buf$=Buf$+Sec$+Chr$(&HF7)+Gap4$
    ' sector data and checksum and end gap
  Next T
  Buf$=Buf$+Gap5$                          ! gaps to track end
Return
'
' **********************
' ***** init: reads machine code into prg$
' **********************
Procedure Init
  Restore Protect
  Do
    Read A$
    Exit If A$="*"
    Prg$=Prg$+Chr$(Val("&h"+A$))
  Loop
Return
'
' **********************
' ****** showtrk: Shows buf$ in hex and ASCII
' ******          press any key to stop then 'X' to exit
' ******          any other key continues
' **********************
Procedure Showtrk
  Print
  Print Ron$;"Show Track Buffer - press any key to stop, then X to exit";Roff$
  For T=1 To Len(Buf$) Step 16
    Z$=""
    A$=Hex$(T-1)
    While Len(A$)<4
      A$="0"+A$
    Wend
    Print "$";A$;"  ";
    For I=0 To 15
      A$=Hex$(Asc(Mid$(Buf$,T+I,1)))
      If Len(A$)=1
        A$="0"+A$
      Endif
      Print A$'
      Z=Val("&h"+A$)
      If Z>31 And Z<128
        Z$=Z$+Chr$(Val("&h"+A$))
      Else
        Z$=Z$+"."
      Endif
    Next I
    Print "  ";Z$
    K$=""
    If Inkey$>""
      K$=Input$(1)
    Endif
    Exit If Upper$(K$)="X"
  Next T
Return
'
' **********************
' * machine code data
' **********************
Protect:
Data 60,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0
Data 0,0,0,0,0,0,0,0,48,E7,FF,FE,42,80,61,0
Data 0,AE,45,FA,FF,E6,24,80,45,FA,FF,E4,34,BC,0,0
Data 2C,3A,FF,D0,50,F9,0,0,4,3E,BC,BC,0,0,0,0
Data 67,0,0,A4,BC,BC,0,0,0,1,67,0,0,E0,51,F9
Data 0,0,4,3E,45,FA,FF,B4,20,12,61,72,4C,DF,7F,FF
Data 4E,75,32,3C,0,1E,61,A,33,C7,0,FF,86,4,32,3C
Data 0,1E,51,C9,FF,FE,4E,75,32,3C,0,FA,51,C9,FF,FE
Data 22,3C,0,4,0,0,8,39,0,5,0,FF,FA,1,67,C
Data 53,81,66,F2,1E,3C,0,D0,61,40,4E,75,33,FC,1,80
Data 0,FF,86,6,32,3C,0,1E,61,C8,30,39,0,FF,86,4
Data 32,3C,0,1E,60,BC,13,C7,0,FF,86,D,E0,8F,13,C7
Data 0,FF,86,B,E0,8F,13,C7,0,FF,86,9,4E,75,2F,0
Data 3F,3C,0,20,4E,41,5C,8F,4E,75,1E,3C,0,D0,61,82
Data 32,3C,0,FA,60,8C,38,3C,0,2,61,0,0,D6,38,3C
Data 0,29,61,0,0,92,61,C,38,3C,0,0,61,0,0,C4
Data 60,0,FF,4C,2E,3A,FF,0,61,AC,61,0,0,9C,3E,3C
Data 0,E,61,0,FF,4E,33,FC,0,80,0,FF,86,6,3E,3C
Data 0,E0,61,0,FF,3E,61,0,FF,50,4E,75,38,3C,0,2
Data 61,0,0,90,38,3C,0,29,61,4C,61,C,38,3C,0,0
Data 61,0,0,80,60,0,FF,8,2E,3A,FE,BC,61,0,FF,68
Data 33,FC,1,90,0,FF,86,6,33,FC,0,90,0,FF,86,6
Data 33,FC,1,90,0,FF,86,6,3E,3C,0,1F,61,0,FE,F4
Data 33,FC,1,80,0,FF,86,6,3E,3C,0,F0,61,0,FE,E4
Data 61,0,FE,F6,4E,75,33,FC,0,86,0,FF,86,6,3E,4
Data 61,0,FE,D0,33,FC,0,80,0,FF,86,6,3E,3C,0,11
Data 61,0,FE,C0,60,0,FE,D2,33,FC,0,90,0,FF,86,6
Data 33,FC,1,90,0,FF,86,6,33,FC,0,90,0,FF,86,6
Data 4E,75,48,E7,FF,FE,3E,4,66,14,33,FC,0,80,0,FF
Data 86,6,32,39,0,FF,86,4,8,1,0,7,66,F4,A,7
Data 0,7,CE,3C,0,7,40,E7,0,7C,7,0,13,FC,0,E
Data 0,FF,88,0,10,39,0,FF,88,0,C0,3C,0,F8,8E,0
Data 13,C7,0,FF,88,2,46,DF,4C,DF,7F,FF,4E,75,0,0
Data *