DEFLNG a-Z

'Assumes exec.bmap and midi.bmap in the current directory
LIBRARY "exec.library"
LIBRARY "midi.library"

DECLARE FUNCTION AllocMem() LIBRARY
memf.public = 1
memf.clear = 65536&

DECLARE FUNCTION CreateMDest() LIBRARY
DECLARE FUNCTION CreateMSource() LIBRARY
DECLARE FUNCTION GetMidiMsg() LIBRARY
DECLARE FUNCTION MRouteDest() LIBRARY
DECLARE FUNCTION MRouteSource() LIBRARY
DestName$="MidiOut"+CHR$(0)
SourceName$="MidiIn"+CHR$(0)
NoteOn=&H90
DefaultVelocity=&H40

NoteBufSize=12
NoteBuf=AllocMem(NoteBufSize,memf.public+memf.clear)
IF NoteBuf=0 THEN CloseDown

InRouteInfoSize=14
InRouteInfo=AllocMem(InRouteInfoSize,memf.public+memf.clear)
IF InRouteInfo=0 THEN CloseDown
POKEW InRouteInfo  ,&H2     'Allow only Note On messages
POKEW InRouteInfo+2,&HFFFF  'pass all channels

OutRouteInfoSize=14
OutRouteInfo=AllocMem(OutRouteInfoSize,memf.public+memf.clear)
IF OutRouteInfo=0 THEN CloseDown
POKEW OutRouteInfo  ,&HFFFF  'Allow all messages
POKEW OutRouteInfo+2,&HFFFF  'pass all channels

CPG:
LOCATE 2,10 : PRINT"CPG for the Amiga"
PRINT" by Jim McConkey after Atari ST original by Jim Johnson"
PRINT" Published in Electronic Musician, April 1988, pp 22-30"
Dest=CreateMDest(0&,0&)
IF Dest=0 THEN PRINT"Can't create Dest": GOTO CloseDown
Source=CreateMSource(0&,0&)
IF Source=0 THEN PRINT"Can't create Source": GOTO CloseDown

Out=MRouteSource(Source,SADD(DestName$),OutRouteInfo)
IF Out=0 THEN PRINT"Can't route MIDI output": GOTO CloseDown
In=MRouteDest(SADD(SourceName$),Dest,InRouteInfo)
IF In=0 THEN PRINT"Can't route MIDI input" : GOTO CloseDown

 GOSUB SetVar
Start:
 GOSUB SetBuff
 GOSUB DoScreen
 GOSUB GetScale
 GOSUB MakeProg
 GOSUB MakeChords
 GOSUB Play
 GOSUB AskMore
 IF a$<>"N" THEN GOTO Start
  
CloseDown:
IF Dest<>0 THEN CALL DeleteMDest(Dest)
IF Source<>0 THEN CALL DeleteMSource(Source)
IF In<>0 THEN CALL DeleteMRoute(In)
IF Out<>0 THEN CALL DeleteMRoute(Out)
IF InRouteInfo<>0 THEN CALL FreeMem(InRouteInfo,InRouteInfoSize)
IF OutRouteInfo<>0 THEN CALL FreeMem(OutRouteInfo,OutRouteInfoSize)
IF NoteBuff<>0 THEN CALL FreeMem(NoteBuff,NoteBufSize)
LIBRARY CLOSE : CLS
END

SetBuff:
 FOR j=0 TO 3
  POKE NoteBuf+3*j  ,NoteOn
  POKE NoteBuf+3*j+1,0
  POKE NoteBuf+3*j+2,DefaultVelocity
 NEXT
RETURN

DoScreen:
 LOCATE 15,10
 PRINT "Chord Progression Generator" : PRINT 
RETURN

SetVar:
 DIM Scale(8),Chord(100,4),Prog(100),Type(7)
 I=1 : II=2 : III=3 : IV=4 : V=5 : VI=6 : VII=7
 Tonic=1 : Digress=2 : Approach=3
 Type(I)=Tonic : Type(II)=Digress : Type(III)=Digress
 Type(IV)=Approach : Type(V)=Approach
 Type(VI)=Digress : Type(VII)=Approach
RETURN

GetScale:
 CALL FlushMDest(Dest)     'Clean out buffer
 FOR j=1 TO 8              'Now get scale
  LOCATE 17,10
  PRINT "Enter scale note"j
  NoteMsg=0
  WHILE NoteMsg=0
   NoteMsg=GetMidiMsg(Dest)
  WEND
  Scale(j)=PEEK(NoteMsg+1)
  FreeMidiMsg(NoteMsg)
 NEXT
 LOCATE 17,10 : PRINT SPACE$(20)
RETURN

MakeProg:
 RANDOMIZE(0)
 Prog(1)=I
 FOR j=2 TO 100
  Rn!=(RND)^1.3
  IF Type(Prog(j-1))=Tonic THEN
   ON INT(Rn!*6)+1 GOSUB T3,T4,T6,T5,T2,T7
  ELSEIF Type(Prog(j-1))=Digress THEN 
   ON INT(Rn!*3)+1 GOSUB T5,T7,T1
  ELSEIF Type(Prog(j-1))=Approach THEN 
   GOSUB T1
  END IF
  IF j>=5 AND Type(Prog(j-1))=Approach THEN Prog(j+1)=0 : j=100
 NEXT
RETURN

T1: Prog(j)=I   : RETURN
T2: Prog(j)=II  : RETURN
T3: Prog(j)=III : RETURN
T4: Prog(j)=IV  : RETURN
T5: Prog(j)=V   : RETURN
T6: Prog(j)=VI  : RETURN
T7: Prog(j)=VII : RETURN

MakeChords:
 j=1
 WHILE Prog(j)<>0
  Root=Prog(j)
  Third=Root+2
  IF Third>8 THEN Third=Third-7
  Fifth=Root+4
  IF Fifth>8 THEN Fifth=Fifth-7
  Chord(j,1)=Scale(Root)-12
  Chord(j,2)=Scale(Root)
  Chord(j,3)=Scale(Third)
  Chord(j,4)=Scale(Fifth)
  j=j+1
 WEND
RETURN

Play:
 j=1
 WHILE Prog(j)<>0
  POKE NoteBuf+1,Chord(j,1)
  POKE NoteBuf+4,Chord(j,2)
  POKE NoteBuf+7,Chord(j,3)
  POKE NoteBuf+10,Chord(j,4)
  CALL PutMidiStream(Source,0,NoteBuf,12,12)
  POKE NoteBuf+2,0
  POKE NoteBuf+5,0
  POKE NoteBuf+8,0
  POKE NoteBuf+11,0
  FOR j2=1 TO 2000 : NEXT
  CALL PutMidiStream(Source,0,NoteBuf,12,12)
  POKE NoteBuf+2,DefaultVelocity
  POKE NoteBuf+5,DefaultVelocity
  POKE NoteBuf+8,DefaultVelocity
  POKE NoteBuf+11,DefaultVelocity
  FOR j2=1 TO 2000 : NEXT
  j=j+1
 WEND
 length=j-1
RETURN

AskMore:
 LOCATE 17,10
 PRINT "Generate another progression (Y/N)?"
 a$=""
 WHILE a$<>"Y" AND a$<>"N"
  a$=UCASE$(INKEY$)
 WEND
 LOCATE 17,10 : PRINT SPACE$(40)
RETURN

 
