;********************************************************************
;*                                                                  *
;*                      S  O  P  R  O  L                            *
;*                                                                  *
;*          Sound  Programming  Language  for the Amiga             *
;*                                                                  *
;*     written by Holger Gehrmann, West-Germany    Feb. 1987        *
;*                                                                  *
;********************************************************************



run:      jmp begin

genbase   =$dff0a0
anfinstr  =$60000
adsrbase: dc.l 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
instrbase:dc.l 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
poi1:     dc.l 0,0,0,0
stacks:   dc.l 0,0,0,0
nocnt:    dc.b 0,0,0,0
aklength: dc.b 0,0,0,0
trans:    dc.b 6,0
handle:   dc.l 0
curname:  dc.l 0
curanf:   dc.l 0

TBegin      =0
Length      =4
LoopLength  =6
Octave      =8
SAttackWait =9
SAttackStep =10
SSustainWait=11
SDecayWait  =12
SDecayStep  =13
SEndval     =14
SVolume     =15

AttackWait  =0
Attackstep  =1
SustainWait =2
DecayWait   =3
DecayStep   =4
Endval      =5
IPhase      =6
ICount      =7
IVolume     =8

;#### dos_lib.i ####

ando  =-24

Open          =ando-6
Close         =ando-12
Read          =ando-18
Write         =ando-24
Input         =ando-30
Output        =ando-36
Seek          =ando-42
DeleteFile    =ando-48
Rename        =ando-54
Lock          =ando-60
UnLock        =ando-66
DupLock       =ando-72
Examine       =ando-78
ExNext        =ando-84
Info          =ando-90
CreateDir     =ando-96
CurrentDir    =ando-102
IoErr         =ando-108
CreateProc    =ando-114
Exit          =ando-120
LoadSeg       =ando-126
UnLoadSeg     =ando-132
GetPacket     =ando-138
QueuePacket   =ando-144
DeviceProc    =ando-150
SetComment    =ando-156
SetProtection =ando-162
DateStamp     =ando-168
Delay         =ando-174
WaitForChar   =ando-180
ParentDir     =ando-186
IsInteractive =ando-192
Execute       =ando-198


;#### exec/exec_lib.i ####

anex=-24

Supervisor      =anex-6
ExitIntr        =anex-12
Schedule        =anex-18
Eeschedule      =anex-24
Switch          =anex-30
Dispatch        =anex-36
Exception       =anex-42
InitCode        =anex-48
InitStruct      =anex-54
MakeLibrary     =anex-60
MakeFunctions   =anex-66
FindResident    =anex-72
InitResident    =anex-78
Alert           =anex-84
Debug           =anex-90
Disable         =anex-96
Enable          =anex-102
Forbid          =anex-108
Permit          =anex-114
SetSR           =anex-120
SuperState      =anex-126
UserState       =anex-132
SetIntVector    =anex-138
AddIntServer    =anex-144
RemIntServer    =anex-150
Cause           =anex-156
Allocate        =anex-162
Deallocate      =anex-168
AllocMem        =anex-174
AllocAbs        =anex-180
FreeMem         =anex-186
AvailMem        =anex-192
AllocEntry      =anex-198
FreeEntry       =anex-204
Insert          =anex-210
AddHead         =anex-216
AddTail         =anex-222
Remove          =anex-228
RemHead         =anex-234
RemTail         =anex-240
Enqueue         =anex-246
FindName        =anex-252
AddTask         =anex-258
RemTask         =anex-264
FindTask        =anex-270
SetTaskPri      =anex-276
SetSignal       =anex-282
SetExcept       =anex-288
Wait            =anex-294
Signal          =anex-300
AllocSignal     =anex-306
FreeSignal      =anex-312
AllocTrap       =anex-318
FreeTrap        =anex-324
AddPort         =anex-330
RemPort         =anex-336
PutMsg          =anex-342
GetMsg          =anex-348
ReplyMsg        =anex-354
WaitPort        =anex-360
FindPort        =anex-366
AddLibrary      =anex-372
RemLibrary      =anex-378
OldOpenLibrary  =anex-384
CloseLibrary    =anex-390
SetFunction     =anex-396
SumLibrary      =anex-402
AddDevice       =anex-408
RemDevice       =anex-414
Opendevice      =anex-420
CloseDevice     =anex-426
DoIO            =anex-432
SendIO          =anex-438
CheckIO         =anex-444
WaitIO          =anex-450
AbortIO         =anex-456
AddResource     =anex-462
RemResource     =anex-468
OpenResource    =anex-474
RawIOInit       =anex-480
RawMayGetChar   =anex-486
RawPutChar      =anex-492
RawDoFmt        =anex-498
GetCC           =anex-504
TypeOfMem       =anex-510
Procure         =anex-516
Vacate          =anex-522
OpenLibrary     =anex-528



Effect      =$f4f4f4f0
Call        =$f4f4f4f1
Recall      =$f4f4f4f2
Rec         =$f4f4f4f2
Jump        =$f4f4f4f3
NoOperation =$f4f4f4f4
Restart     =$f4f4f4f5

anfslap     =$60000
anfkoto     =$62000
anfvoice    =$64000
anfbass     =$66000
anfsnare    =$68000
anfclaps    =$6a000
anfwhist    =$6c000
anfsdrums   =$6e000

nados:      dc.b "dos.library",0

names:      dc.b "df1:slapbass.sh",0,"  "
            dc.b "df1:koto.sh",0,"      "
            dc.b "df1:lead.sh",0,"      "
            dc.b "df1:bassdrum.sh",0,"  "
            dc.b "df1:snaredrum.sh",0," "
            dc.b "df1:claps.sh",0,"     "
            dc.b "df1:whistle.sh",0,"   "
            dc.b "df1:synthdrums.sh",0
            dc.b 0,0

even

notab:      dc.w 54784,51712,48768,46080,43392,40960,38656,36480
            dc.w 34432,32512,30720,28928,27392,27392,27392,27392

;******** song data anfang *****************************************

eff1:     dc.l effect,anfslap,$1c710000,$020040ff,$ff0040f4,recall
eff2:     dc.l effect,anfkoto,$11400000,$020040ff,$ff0040f4,recall
eff3:     dc.l effect,anfvoice,$249f0000,$020040ff,$ff0040f4,recall
eff4:     dc.l effect,anfbass,$10000000,$020040ff,$ff001038,recall
eff5:     dc.l effect,anfsnare,$10000000,$020040ff,$ff001038,recall
eff6:     dc.l effect,anfclaps,$10000000,$020040ff,$ff001038,recall
effp:     dc.l effect,anfclaps,$10000000,$020040ff,$ff001000,recall
eff7:     dc.l effect,anfwhist,$08000000,$030040ff,$ff0040f4,recall
eff8:     dc.l effect,anfsdrums,$10000000,$030040ff,$ff0040f4,recall
basa:     dc.l call,eff1,$c4495949,$59f2f4f4
basg:     dc.l $c4475747,$57f2f4f4
basf:     dc.l $c4455545,$55f2f4f4
basd:     dc.l $c4425242,$52f2f4f4
basge:    dc.l $c4475744,$54f2f4f4
blea:     dc.l call,eff2,$c2495054,$59495054,$59f2f4f4
bleg:     dc.l $c2474b52,$57474b52,$57f2f4f4
blege:    dc.l $c2474b52,$5744474b,$54f2f4f4
blef:     dc.l $c2454950,$55454950,$55f2f4f4
bled:     dc.l $c2424549,$52424549,$52f2f4f4
basb1:    dc.l call,basa,call,basa,call,basf,call,basg,call,basa
          dc.l call,basa,call,basd,call,basge,recall
basb2:    dc.l call,basa,call,basa,call,basa,call,basg,call,basa
          dc.l call,basa,call,basf,call,basg,call,basa,call,basa
          dc.l call,basa,call,basg,call,basa,call,basa
          dc.l call,basf,call,basg,call,basf,call,basf,call,basg
          dc.l call,basg,call,basf,call,basf,call,basg,call,basg,rec
ble1:     dc.l call,blea,call,blea,call,blef,call,bleg,call,blea
          dc.l call,blea,call,bled,call,blege,recall
ble1a:    dc.l call,blea,call,blea,call,blef,call,bleg,call,blea
          dc.l call,blea,call,spart,recall
mel1:     dc.l call,eff3,$c4494950,$c249c454,$c249c450,$4b47f2f4
spart:    dc.l call,eff3,$c449f4f4,call,eff8,$3838c234,$c43430c2
          dc.l $2ac42a25,recall
spart2:   dc.l $c4525255,$c252c447,$47c247c4,$4b47f2f4
schla1:   dc.l call,eff4,$c850f4f4,call,eff5,$c450f4f4,call,eff4
          dc.l $50c850f4,call,eff5,$c450f4f4,call,eff4,$c850c450
          dc.l call,eff5,$50f4f4f4,call,eff4,$5050f4f4,call,eff6
          dc.l $494949f2
schla2:   dc.l call,eff4,$c850f4f4,call,eff5,$c450f4f4,call,eff4
          dc.l $50c850f4,call,eff5,$c450f4f4,call,eff4,$c850c450
          dc.l call,eff5,$50f4f4f4,call,eff4,$5050f4f4,call,eff6
          dc.l $c249c449,$c2494949,recall
paub:     dc.l call,effp,$c8505050,$50505050,$50f2f4f4
hmel1:    dc.l call,eff7,$c4505050,$5050504b,$c850dc49,recall
hmel2:    dc.l $c4505050,$50504b47,$e449f2f4
hmel3:    dc.l $c4505050,$50c852c4,$50e454f2

song1a:   dc.l call,paub
          dc.l call,basb1,call,basb1,call,basb1,call,basb1
          dc.l call,basb2,restart

song1b:   dc.l call,paub,call,paub,call,paub,call,paub,call,paub
          dc.l call,ble1a,call,ble1a,call,hmel1,call,hmel2,call,hmel1
          dc.l call,hmel3,restart

song1c:   dc.l call,paub,call,paub,call,paub
sl3:      dc.l call,mel1,call,mel1,call,mel1,call,spart2,jump,sl3

song1d:   dc.l call,schla1
sl4:      dc.l call,schla1,call,schla2,jump,sl4    

even

tonerz:   nop   ;Generator D0, Ton D1
          movem.l d0-d7/a0-a6,-(sp)
          jsr keytranspose
          and.l #3,d0
          move.l d0,d2
          asl.b #4,d2
          move.l d2,a0
          move.l d2,a1
          move.l d2,a2
          add.l #GenBase,a0
          add.l #InstrBase,a1
          add.l #AdsrBase,a2
          move.l #$00010001,4(a0)       ;reset generator
          move.w #350,d5
te0:      subq.w #1,d5
          tst.w d5
          bne te0
          clr.b IVolume(a2)
          move.b #1,IPhase(a2)
          move.b AttackWait(a2),ICount(a2)
          move.b Octave(a1),d3
          asl.b #4,d3
          add.b d3,d1
          move.b d1,d3
          and.l #$0f,d1
          asl.b #1,d1
          add.l #notab,d1
          move.l d1,a4
          move.w (a4),d4
          lsr.b #4,d3
te2:      tst.b d3
          beq te1
          lsr.w #1,d4
          subq.b #1,d3
          jmp te2
te1:      move.w #1,d7
          tst.b d0
          beq te1a
te1b:     asl.w #1,d7
          subq.b #1,d0
          tst.b d0
          bne te1b
te1a:     move.w d7,$dff096
          move.w d4,6(a0)
          move.l TBegin(a1),(a0)
          move.w Length(a1),4(a0)
          move.b SVolume(a1),9(a0)
          or.w #$8000,d7
          move.w d7,$dff096
          movem.l (sp)+,d0-d7/a0-a6
          rts

keytranspose:nop
          move.b trans,d7
          tst.b d7
          beq kt1
kt3:      addq.b #1,d1
          move.b d1,d6
          and.b #$0f,d6
          cmp.b #$0c,d6
          bne kt2
          add.b #$10,d1
          and.b #$f0,d1
kt2:      subq.b #1,d7
          bne kt3
kt1:      rts

init:     move.l #InstrBase,a0
          move.w $60006,d0       ;length
          lsr.w #1,d0
          move.w d0,Length(a0)
          move.w d0,$dff0a4
          move.w #428,$dff0a6     ;pitch
          move.w #$40,$dff0a8     ;volume
          move.w #$800f,$dff096   ;DMA
          move.l #$60030,$dff0a0  ;location
          move.l #$60030,TBegin(a0)
          move.b #2,Octave(a0)
          move.w #$0088,$dff09e
          move.l #stackanf,stacks
          move.l #stackanf+40,stacks+4
          move.l #stackanf+80,stacks+8
          move.l #stackanf+120,stacks+12
          rts

begin:    nop
          cmp.w #$1c71,anfinstr
          beq ru3
          move.l $4,a5
          move.l #nados,a1
          move.l #0,d0
          jsr OpenLibrary(a5)
          move.l d0,a5
          move.l #names,curname
          move.l #anfinstr,curanf

ru4:      move.l curname,d1
          move.l #1005,d2
          jsr Open(a5)
          move.l d0,handle
          move.l d0,d1
          move.l curanf,d2
          move.l #$2000,d3
          jsr Read(a5)
          move.l handle,d1
          move.w d1,d2
          jsr Close(a5)
          add.l #18,curname
          add.l #$2000,curanf
          move.l curname,a4
          tst.b (a4)
          bne ru4

ru3:      jsr init                   
          move.l #song1a,poi1
          move.l #song1b,poi1+4
          move.l #song1c,poi1+8
          move.l #song1d,poi1+12
ru2:      jsr work
          move.l #17000,d0
ru1:      subq.l #1,d0
          tst.l d0
          bne ru1
          jmp ru2


work:     nop
          move.l #poi1,a6
          move.l #stacks,a2
          move.l #InstrBase,a1
          move.l #aklength,a4
          move.l #0,d4            ;generator#
          move.l #nocnt,a0
wo0:      move.l (a2),a3
          tst.b (a0)
          beq wo1
          subq.b #1,(a0)
          tst.b (a0)
          bne wow
wo1:      move.l (a6),a5
          move.b (a5),d0     ;Befehl lesen
          cmp.b #$f4,d0      ;NOP
          bne wo2
          addq.l #1,(a6)
          jmp wo1
wo2:      cmp.b #$f3,d0      ;jump
          bne wo3
          addq.l #1,(a6)
          addq.l #1,a5
          move.l (a5),(a6)
          move.l (a6),a5
          jmp wo1
wo3:      cmp.b #$f1,d0      ;call
          bne wo4
          addq.l #1,a5
          move.l a5,(a3)
          addq.l #4,a3
          addq.l #4,(a2)
          move.l (a5),(a6)
          move.l (a6),a5
          jmp wo1
wo4:      cmp.b #$f2,d0      ;recall
          bne wo5
          subq.l #4,a3
          subq.l #4,(a2)
          move.l (a3),a5
          move.l (a3),(a6)
          addq.l #4,a5
          addq.l #4,(a6)
          jmp wo1
wo5:      cmp.b #$f0,d0      ;effect
          bne wo6
          addq.l #1,a5
          addq.l #1,(a6)
          move.l (a5),Tbegin(a1)
          move.l 4(a5),Length(a1)
          move.l 8(a5),Octave(a1)
b2:       move.l 12(a5),SDecayWait(a1)
          add.l #16,a5
          add.l #16,(a6)
          jmp wo1
wo6:      cmp.b #$f5,d0      ;restart
          bne wo6a
          move.w #$000f,$dff096
b1:       nop
          rts
wo6a:     and.b #$f0,d0
          cmp.b #$c0,d0
          beq wo7
          cmp.b #$d0,d0
          beq wo7
          cmp.b #$e0,d0
          bne wo8
wo7:      move.b (a5),d0
          sub.b #$c0,d0
          move.b d0,(a0)
          move.b d0,(a4)
          addq.l #1,a5
          addq.l #1,(a6)
          jmp wo1
wo8:      move.b (a5),d1
          move.b d4,d0
          jsr tonerz
          addq.l #1,a5
          addq.l #1,(a6)
          move.b (a4),(a0)
wow:      nop
          addq.b #1,d4
          addq.l #4,a6
          add.l #16,a1
          addq.l #4,a2
          addq.l #1,a0
          addq.l #1,a4
          cmp.b #4,d4
          bne wo0

          rts



even

stackanf: dc.b 0