sources frrom pc underground part 2

.386p

.MODEL TPASCAL
.DATA

 oldint3 dd ?
 alter_interrupt3 dd ?
.CODE

public protected_stopping
protected_stopping proc pascal
	pusha
	cli                         ; Interrupts ausschalten
	mov eax,cr0                 ; In den Protected-Mode schalten
	or eax,1
	mov cr0,eax
	jmp PROTECTION_ENABLED      ; Executionpipe l”schen
PROTECTION_ENABLED:

	and al,0FEh                 ; Wieder in den Real-Mode schalten
	mov cr0,eax                 ; CPU nicht resetten
	jmp PROTECTION_DISABLED     ; Executionpipe l”schen
PROTECTION_DISABLED:
	sti                         ; Interrupts wieder einschalten
	popa
  ret
protected_stopping endp

public Check_auf_vector
Check_auf_vector proc pascal check : dword;
  mov bx,0
  mov es,bx
  mov bx,18
  mov eax,es:[bx]
  mov oldint3,eax
  mov eax,check
  mov es:[bx],eax
  ret
Check_auf_vector endp

public Vector_ok
Vector_ok proc pascal check : dword;
  mov bx,0
  mov es,bx
  mov bx,18
  mov eax,es:[bx]
  cmp eax,check
  je  @check_ok
  mov al,0
  jmp @check_ende
@check_ok:
  mov al,1
@check_ende:
  ret
Vector_ok endp

public restore_Checkvector
restore_Checkvector proc pascal
  mov bx,0
  mov es,bx
  mov bx,18
  mov eax,oldint3
  mov es:[bx],eax
  ret
restore_Checkvector endp

public Copy_int21_int3
Copy_int21_int3 proc pascal
  mov bx,0
  mov es,bx
  mov bx,18
  mov eax,es:[bx]
  mov alter_interrupt3,eax              ; alten int3 sichern
  mov bx,84                             ; Int 21 laden
  mov eax,es:[bx]
  mov bx,18                             ; in int3 speichern
  mov es:[bx],eax
  ret
Copy_int21_int3 endp








END.386p
.MODEL TPASCAL

keyb_off macro
  push ax
  in  al,21h
  or  al,02
  out 21h,al
  pop ax
endm

keyb_on macro
  push ax
  in  al,21h
  and al,0Fdh
  out 21h,al
  pop ax
endm

.DATA
 extrn Verbleibende_durchlaeufe
 extrn PNeues_Passwort_waehlen : dword
 extrn PEingabe_Box_zeichnen   : dword
 extrn PPasswort_abfragen      : dword
 extrn PSystem_anhalten        : dword
 extrn Passwort_correct        : byte
 extrn unnoetige_Variable1     : word
 extrn unnoetige_Variable2     : word

.CODE
extrn Main_Programm          : far

public Abfrage_Schleife

Abfrage_Schleife proc pascal
  keyb_off

 ;PIQ - Trick
  int 3
  mov  cs:word ptr [@int_21_funkt1],4CB4h  ; Funktion Prg. beenden
@int_21_funkt1:
  mov  ah,30h                         ; Funktion DOS-Vers. ermitteln
  int 21h

@Abfrage_loop:
  keyb_off

  call dword ptr PNeues_Passwort_waehlen
  cmp  unnoetige_Variable1,5
  jbe  @Unnoetiges_Ziel1a

 ;PIQ - Trick
  int 3
  mov  cs:word ptr [@int_21_funkt2],4CB4h  ; Funktion Prg. beenden
@int_21_funkt2:
  mov  ah,30h                         ; Funktion DOS-Vers. ermitteln
  int 21h
  mov  cs:word ptr [@int_21_funkt2],30B4h  ; Funktion Prg. beenden

  call dword ptr PEingabe_Box_zeichnen
  jmp  @Unnoetiges_Ziel1b

@Unnoetiges_Ziel1a:
 ;PIQ - Trick
  int 3
  mov  cs:word ptr [@int_21_funkt2],4CB4h  ; Funktion Prg. beenden
@int_21_funkt2a:
  mov  ah,30h                         ; Funktion DOS-Vers. ermitteln
  int 21h
  mov  cs:word ptr [@int_21_funkt2a],30B4h  ; Funktion Prg. beenden

  call dword ptr PEingabe_Box_zeichnen
@Unnoetiges_Ziel1b:
  keyb_on


  cmp  unnoetige_Variable2,10
  jbe  @Unnoetiges_Ziel2a

  dec  byte ptr Verbleibende_durchlaeufe

; Protected MODE Trick
	pusha
	cli                         ; Interrupts ausschalten
	mov eax,cr0                 ; In den Protected-Mode schalten
	or eax,1
	mov cr0,eax
	jmp PROTECTION_ENABLED      ; Executionpipe l”schen
PROTECTION_ENABLED:
	and al,0FEh                 ; Wieder in den Real-Mode schalten
	mov cr0,eax                 ; CPU nicht resetten
	jmp PROTECTION_DISABLED     ; Executionpipe l”schen
PROTECTION_DISABLED:
	sti                         ; Interrupts wieder einschalten
	popa

  call dword ptr PPasswort_abfragen
  jmp  @Unnoetiges_Ziel2b

@Unnoetiges_Ziel2a:
  dec  byte ptr Verbleibende_durchlaeufe

; Protected MODE Trick
	pusha
	cli                         ; Interrupts ausschalten
	mov eax,cr0                 ; In den Protected-Mode schalten
	or eax,1
	mov cr0,eax
	jmp PROTECTION_ENABLED2a      ; Executionpipe l”schen
PROTECTION_ENABLED2a:
	and al,0FEh                 ; Wieder in den Real-Mode schalten
	mov cr0,eax                 ; CPU nicht resetten
	jmp PROTECTION_DISABLED2a     ; Executionpipe l”schen
PROTECTION_DISABLED2a:
	sti                         ; Interrupts wieder einschalten
	popa
  call dword ptr PPasswort_abfragen

@Unnoetiges_Ziel2b:

  cmp  byte ptr Passwort_correct,1
  je   @Abfrage_war_OK
  jmp  @Abfrage_war_nicht_OK
@Abfrage_war_OK:

  call Main_Programm
@Abfrage_war_nicht_OK:

  cmp byte ptr Verbleibende_durchlaeufe,54
  ja  @Abfrage_loop
  call dword ptr PSystem_anhalten
  ret
Abfrage_schleife endp

END{$F+}
{$M $4000,500000,650000}
program passwortabfrage;

uses crt,design;
const Passwoerter : array[1..10] of string =
        ('Data Becker','Inspire','PC Underground','Soundblaster',
         'Demos','Super','Vengeance','Dynamite','Bier','Haus');
      Pw_Pages : array[1..10] of word =
        (17,3,29,43,12,21,4,9,13,30);

Var pw_nr : byte;
    verbleibende_durchlaeufe : byte;
    Passwort_correct : word;
    New_Pass : string;
    PNeues_Passwort_waehlen : pointer;
    PEingabe_Box_zeichnen : pointer;
    PPasswort_abfragen : pointer;
    PSystem_anhalten : pointer;
    unnoetige_Variable1 : word;
    unnoetige_Variable2 : word;

{$L Pwmodul}
procedure Abfrage_Schleife; far; external;

procedure Neues_Passwort_waehlen;
begin;
  pw_nr := random(10)+1;
  unnoetige_Variable1 := 1;
  unnoetige_Variable2 := 2;
end;

procedure Eingabe_Box_zeichnen;
var pws : string;
begin;
  str(Pw_Pages[pw_nr]:2,pws);
  asm int 3; end;
  Fenster(20,10,40,4,'Bitte Passwort auf Seite '+pws+' eingeben',black,7);
  unnoetige_Variable1 := 1;
  unnoetige_Variable2 := 2;
  gotoxy(23,12);
end;

procedure Passwort_abfragen;
begin;
  readln(New_Pass);
  unnoetige_Variable1 := 1;
  unnoetige_Variable2 := 2;
  if New_Pass = Passwoerter[pw_nr] then
    Passwort_correct := 1
  else
    Passwort_correct := 0;
end;

procedure System_anhalten;
begin;
  textbackground(black);
  textcolor(7);
  clrscr;
  writeln('Wir h„tten doch wohl besser ein Orginal gekauft ...');
  halt(0);
end;


procedure Main_Programm;
begin;
  textbackground(black);
  textcolor(7);
  clrscr;
  gotoxy(20,12);
  writeln('Wilkommen im Hauptprogramm !');
  gotoxy(20,22);
  write('Enter zum Beenden ... ');
  readln;
  halt(0);
end;

begin;
  textbackground(black);
  textcolor(7);
  clrscr;
  verbleibende_durchlaeufe := 57;
  PNeues_Passwort_waehlen := @Neues_Passwort_waehlen;
  PEingabe_Box_zeichnen   := @Eingabe_Box_zeichnen;
  PPasswort_abfragen      := @Passwort_abfragen;
  PSystem_anhalten        := @System_anhalten;
  randomize;
  Abfrage_Schleife;
end.unit design;

interface
uses crt,windos;

procedure writexy(x,y : integer;s : string);
procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
function wrhexb(b : byte) : string;
function wrhexw(w : word) : string;
procedure save_screen;
procedure restore_screen;
Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
procedure cursor_On;
procedure cursor_Off;

implementation

var filenames : array[1..512] of string[12];
const      Screen_Akt   : byte = 1;

procedure writexy(x,y : integer;s : string);
begin;
 gotoxy(x,y);
 write(s);
end;

procedure save_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt <= 4 then begin;
    inc(Screen_Akt);
    move(screen[1],screen[Screen_Akt],8000);
  end;
end;

procedure restore_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt >= 2 then begin;
    move(screen[Screen_Akt],screen[1],8000);
    dec(Screen_Akt);
  end;
end;

procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
const frames : array[1..2,1..6] of char =
 (('Ú','¿','Ù','À','Ä','³'),
  ('É','»','¼','È','Í','º'));
var lx,ly : integer;
    s : string;
begin;
  { obere Zeile }
  s := frames[rt,1];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,2];
  gotoxy(startx,starty);
  write(s);
  { mittleren Zeilen }
  for ly := 1 to dy-2 do begin;
    s := frames[rt,6];
    for lx := 1 to dx-2 do s := s + ' ';
    s := s + frames[rt,6];
    gotoxy(startx,starty+ly);
    write(s);
  end;
  { untere Zeile }
  s := frames[rt,4];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,3];
  gotoxy(startx,starty+dy-1);
  write(s);
end;

Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
var tlaeng : byte;
    deltx,tstartpos : byte;
begin;
  tlaeng := length(s);
  tstartpos := x + ((dx-Tlaeng) SHR 1);
  textcolor(rcol);
  textbackground(bcol);
  rahmen(1,x,y,dx,dy);
  writexy(tstartpos,y,s);
end;

procedure sort_filenames(start,ende : integer);
{
 Hier sollte fr gr”áere Verzeichnise Quick-Sort eingebaut werden !
}
var hilfe : string;
    l1,l2 : integer;
begin;
  for l1 := start to ende-1 do begin;
    for l2 := start to ende-1 do begin;
      if filenames[l2] > filenames[l2+1] then begin;
        hilfe := filenames[l2];
        filenames[l2] := filenames[l2+1];
        filenames[l2+1] := hilfe;
      end;
    end;
  end;
end;

function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
const  zeile : byte = 1;
  spalte : byte = 0;
  Start_fndisp : word = 0;
var
  DirInfo: TSearchRec;
  count : integer;
  Nullpos : byte;
var li,lj : integer;
    inp : char;
    retval : string;
    kasten_gefunden : boolean;
    select : byte;
    changed : boolean;
    End_fndisp : word;
begin
  {$I+}
  for li := 1 to 512 do filenames[li] := ' - - -';
  count := 1;
  FindFirst(mask, faArchive, DirInfo);
  while DosError = 0 do
  begin
    filenames[count] := (DirInfo.Name);
    Nullpos := pos(#0,filenames[count]);
    if Nullpos <> 0 then
      filenames[count] := copy(filenames[count],0,Nullpos-1);
    inc(count);
    FindNext(DirInfo);
  end;
  {$I-}

  sort_filenames(1,count-1);
  save_screen;
  Fenster(5,4,72,16,comment,black,7);
  textcolor(1);
  writexy(21,5,'         Bitte Datei ausw„hlen');
  textcolor(black);
  inp := #255;
  changed := true;
  repeat
    textcolor(black);
    if changed then begin;
      changed := false;
      for lj := 0 to 4 do begin;
        for li := 1 to 12 do begin;
          writexy(7+lj*14,5+li,'            ');
          writexy(7+lj*14,5+li,filenames[lj*12+li+Start_fndisp]);
        end;
      end;
      textcolor(14);
      writexy(7+Spalte*14,5+Zeile,filenames[Spalte*12+Zeile+Start_fndisp]);
    end;
    if keypressed then inp := readkey;
    if ord(inp) = 0 then inp := readkey;
    case ord(inp) of
      32,
      13: begin;
            inp := #13;
            changed := true;
            if (pos('- - -',filenames[Spalte*12+Zeile+Start_fndisp]) = 0) then
              retval := filenames[Spalte*12+Zeile+Start_fndisp]
            else
              retval := 'xxxx';
          end;
      27: begin;
            inp := #27;
            changed := true;
            retval := 'xxxx';
          end;
      71: begin; { Pos 1 }
            inp := #255;
            Zeile  := 1;
            Spalte := 0;
            changed := true;
          end;
      72: begin; { Pfeil up }
            inp := #255;
            changed := true;
            if not ((Zeile = 1) and (Spalte = 0)) then
              dec(Zeile);
            if Zeile = 0 then begin;
              dec(Spalte);
              Zeile := 12;
            end;
          end;
      73: begin; { Page UP }
            if Start_fndisp >= 12 then
              dec(Start_fndisp,12)
            else begin;
              Start_fndisp := 0;
              Zeile := 1;
            end;
            inp := #255;
            changed := true;
          end;
      81: begin; { Page Down }
            if ((Spalte+1)*12+Start_fndisp < count) and
            (Start_fndisp < 500) then
              inc(Start_fndisp,12)
            else
              Start_fndisp := count-11;
            inp := #255;
            changed := true;
          end;
      75: begin; { Pfeil links }
            inp := #255;
            changed := true;
            if Spalte = 0 then begin;
              if Start_fndisp >= 12 then dec(Start_fndisp,12);
            end else begin;
              if Spalte > 0 then dec(Spalte);
            end;
          end;
      77: begin; { Pfeil rechts }
            inp := #255;
            changed := true;
            if Spalte = 4 then begin;
              if ((Spalte+1)*12+Start_fndisp < count) and
              (Start_fndisp < 500) then inc(Start_fndisp,12);
            end else begin;
            if (Spalte < 4) and
              (Zeile+(Spalte+1)*12+Start_fndisp < count) then
                inc(Spalte);
            end;
          end;
      79: begin; { End }
            inp := #255;
            changed := true;
            Spalte := (count-Start_fndisp-12) div 12;
            Zeile := (count-Start_fndisp) - Spalte*12 -1;
          end;
      80: begin; { Pfeil down }
            inp := #255;
            changed := true;
            if ((Zeile = 12) and (Spalte = 4)) then begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then begin;
                inc(Start_fndisp,1);
              end;
            end else begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then
                inc(Zeile);
             end;
            if Zeile > 12 then begin;
              inc(Spalte);
              Zeile := 1;
            end;
          end;
      82 : begin;
            changed := true;
             save_screen;
             textcolor(black);
             rahmen(2,16,9,45,5);
             writexy(20,10,' Dateinamen eingeben ('+mtext+')');
             writexy(20,12,'Name: ');
             readln(retval);
             if retval = '' then retval := 'xxxx';
             restore_screen;
           end;
     end;
  until (inp = #13) or (inp = #27) or (inp = #32)
     or (inp = #82);
  restore_screen;
  textbackground(black);
  textcolor(7);
  select_datei := retval;
end;

function wrhexb(b : byte) : string;
const hexcar : array[0..15] of char =
 ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
begin;
  wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
end;

function wrhexw(w : word) : string;
begin;
  wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
end;

procedure cursor_Off; assembler;
asm
  xor ax,ax
  mov ah,01h
  mov cx,2020h
  int 10h
end;

procedure cursor_on; assembler;
asm
 mov ah,01h
 mov cx,0607h
 int 10h
end;



begin;
end..286
code segment
assume cs:code,ds:code
org 100h

start:
  jmp main                      ;Sprung zum Hauptprogramm

;residente Prozeduren:

print proc near                 ;gibt ASCIIZ-String an Pos ds:si auf LPT1 aus
print_loop:
  xor ah,ah                     ;Funktion 0
  lodsb                         ;Zeichen holen
  or al,al                      ;fertig, wenn 0 als Abschluá
  je fertig
  xor dx,dx                     ;auf LPT1 ausgeben
  int 17h
  jmp print_loop                ;n„chstes Zeichen
fertig:
  ret
print endp

handler5 proc far               ;Handler fr Interrupt 5
  push es                       ;alle benutzten Register sichern
  push ds
  pusha

  mov ax,cs                     ;es mit PSP-Segment laden
  mov es,ax
  mov ds,ax                     ;auch Datensegment in Codesegment

  mov di,80h                    ;Parameterblock als Puffer
  mov ah,1bh                    ;Funktion 1bh
  xor bx,bx
  int 10h                       ;Video-Status ermitteln

  cli

  mov al,byte ptr cs:[80h+22h]  ;Anzahl Bildschirmzeilen holen
  cmp al,25d
  jbe normal                    ;wenn 25 Bildschirmzeilen, normale Routine

  lea si,klein_Schrift          ;auf 6-Punkt Schrift umschalten
  call print                    ;Code an Drucker
  jmp ausgabe

normal:
  lea si,Groá_Schrift           ;auf 12-Punkt Schrift umschalten
  call print                    ;Code an Drucker

ausgabe:
  sti
  pushf
  call dword ptr [oldint5]      ;normale Ausgabe aktivieren

  popa
  pop ds
  pop es
  iret
handler5 endp

oldint5: dd 0                   ;Original-Vektor
klein_Schrift:  db 1bh,'(s6V'   ;6 Punkte H”he
                db 1bh,'&l12D'  ;12 Zeilen pro Inch
                db 1bh,'(s12H'  ;12 Zeichen pro Inch
                db 0
groá_schrift:    db 1bh,'(s12V' ;12 Punkt H”he
                db 1bh,'&l6D'   ;6 Zeilen pro Inch
                db 1bh,'(s10H'  ;10 Zeichen pro Inch
                db 0

letzte:

main proc near
  mov ax,3505h                  ;Interrupt 5 auslesen
  int 21h
  mov di,bx                     ;es:di zeigt auf installierten Handler
  mov si,bx                     ;ds:si zeigt auf Handler dieses Programmes
  mov cx,4                      ;8 Bytes vergleichen
  repe cmpsw
  jcxz deinstallieren           ;gleich ?, dann deinstallieren

installieren:
  mov word ptr oldint5,bx       ;alten Vektor sichern
  mov word ptr oldint5 + 2,es

  mov ax,2505h                  ;Interrupt 5 umleiten
  lea dx,handler5               ;Offset laden, Segment bereits in ds
  int 21h

  mov ax,ds:[2ch]               ;Environment-Segment laden
  mov es,ax                     ;nach es
  mov ah,49h                    ;und freigeben
  int 21h

  mov ah,9                      ;Installationsmeldung ausgeben
  lea dx,installiert
  int 21h
  lea dx,letzte                 ;bis Label letzte resident bleiben
  inc dx
  int 27h

deinstallieren:
  mov ah,9                      ;Deinstallationsmeldung ausgeben
  lea dx,deinstalliert
  int 21h

  push ds
  lds dx,dword ptr es:[oldint5] ;ds:dx mit altem Vektor laden
  mov ax,2505h                  ;diesen setzen
  int 21h
  pop ds

  mov ah,49h                    ;residenten Speicher freigeben
  int 21h
  int 20h                       ;und beenden
main endp


Installiert:    db 'Neue Print-Screen Funktion installiert',0dh,0ah,'$'
Deinstalliert:  db 'Print-Screen deinstalliert',0dh,0ah,'$'

code ends
end start
Const Basis=$378;               {Basisadresse der par. Schnittstelle}

Procedure PutChar_Par(z:Char);
{gibt ein Zeichen auf Parallelport (Basisadresse in "Basis") aus}
Begin
  While Port[Basis+1] and 128 = 0 Do;
                                {Auf Ende des Busy warten}
  Port[Basis]:=Ord(z);          {Zeichen auf Port legen}

  Port[Basis+2]:=Port[Basis+2] or 1;
                                {Strobe senden}
  Port[Basis+2]:=Port[Basis+2] and not 1;

  While Port[Basis+1] and 64 = 1 do;
                                {Auf Ack warten}
End;

Procedure PutString_Par(s:String);
{gibt String auf Parallel-Port aus, benutzt PutChar_Par)}
Var i:Integer;                  {Zeichenz„hler}
Begin
  For i:=1 to Length(s) do      {jedes Zeichen}
    PutChar_Par(s[i]);          {an den Parallelport schicken}
End;

Begin
  PutString_Par('Hallo, Data Becker Drucker Test'#13#10);
  PutString_Par('abcdefghijklmnopqrstuvwxyz0123456789'#13#10);
End.
Uses Crt,Dos;

Const
  RxR=0;                        {Receive Data, bei Lesezugriffen}
  TxR=0;                        {Transmit Data, bei Schreibzugriffen}
  IER=1;                        {Interrupt Enable}
  IIR=2;                        {Interrupt Identification}
  LCR=3;                        {Line Control}
  MCR=4;                        {Modem Control}
  LSR=5;                        {Line Status}
  MSR=6;                        {Modem Status}
  DLL=0;                        {Divisor Latch High}
  DLH=1;                        {Divisor Latch Low}

  N=0;                          {keine Parit„t}
  O=8;                          {ungerade Parit„t}
  E=24;                         {gerade Parit„t}

  IRQ_Tab:Array[1..4] of Word   {Interrupt-Nummern der Schnittsctellen}
    =(4,3,4,3);
  Base_Tab:Array[1..4] of Word  {Portadressen der Schnittstellen}
    =($3f8,$2f8,$3e8,$2e8);

Var OldInt:Pointer;             {originaler Interrupt-Vektor}
    Key:Char;                   {gedrckte Taste}
    IRQ,                        {IRQ-Nummer des aktuellen Ports}
    Base:Word;                  {Portadresse des aktuellen Ports}
    fertig:Boolean;             {Flag fr Programm-Ende}

Procedure Handler;interrupt;
{Interrupt-Handler, nimmt Zeichen von ser. Port entgegen}
Begin
  Write(Chr(Port[Base+RxR]));   {Zeichen vom Port holen und ausgeben}
  Port[$20]:=$20;               {EOI senden}
End;

Procedure Open_Port(Nr:Word);
{bereitet COM-Port auf Ein-/Ausgabe vor}
Begin
  IRQ:=IRQ_Tab[Nr];             {IRQ-Nummer holen}
  Base:=Base_Tab[Nr];           {Basis-Adress holen}
  GetIntVec(IRQ+8,OldInt);      {Zeiger verbiegen}
  SetIntVec(IRQ+8,@Handler);
  Port[$21]:=Port[$21] and      {IRQ zulassen}
    not (1 shl IRQ);
  Port[Base+MCR]:=11;           {Auxiliary Output, RTS und DTR setzen}
  Port[Base+IER]:=1;            {Interrupt Enable fr Receive}
End;

Procedure Close_Port;
{setzt COM-Interrupts zurck}
Begin
  SetIntVec(IRQ+8,OldInt);      {IRQ-Vektor wiederherstellen}
  Port[Base+MCR]:=0;            {Signale zurcksetzen}
  Port[Base+IER]:=0;            {Interrupts ausschalten}
  Port[$21]:=                   {Interrupt-Controller zurcksetzen}
    Port[$21] or (1 shl IRQ);
End;

Procedure Set_Speed(bps:LongInt);
{setzt Port-Geschwindigkeit}
Var Divisor:Word;
Begin
  Port[Base+LCR]:=Port[Base+LCR]{DLAB einschalten}
    or 128;
  Divisor:=115200 div bps;
  Port[Base+DLL]:=Lo(Divisor);  {Werte in Divsor Latch schreiben}
  Port[BAse+DLH]:=Hi(Divisor);
  Port[Base+LCR]:=Port[Base+LCR]{DLAB ausschalten}
    and not 128;
End;

Procedure Set_Param(Data,Par,Stop:Word);
{setzt die Parameter Datenbits, Parit„t und Stopbits}
Begin
  Port[Base+LCR]:=
    (Data-5)                    {Bit 0-1 auf Datenbit setzen}
    + Par                       {Parit„t dazu}
    + (Stop-1) shl 2;           {Stopbits in Bit 2 des LCR setzen}
End;

Procedure Error;
{wird bei Time-Out in der Sende-Prozedur aufgerufen}
Begin
  WriteLn;
  WriteLn('Sende-Timeout');     {Meldung}
  Close_Port;                   {Port schlieáen}
  Halt(1);                      {und abbrechen}
End;

Procedure Transmit(c:Char);
{sendet Zeichen ber seriellen Port}
Var Time_Out:Integer;           {Z„hler fr Time-Out}
Begin
  Time_Out:=-1;
  While Port[Base+MSR] and 16 = 0 Do Begin
    Dec(Time_Out);              {Warten auf CTS}
    If Time_Out=0 Then Error;
  End;
  Time_Out:=-1;
  While Port[Base+LSR] and 32 = 0 Do Begin
    Dec(Time_Out);              {Warten auf leeres Transmitter-Register}
    If Time_Out=0 Then Error;
  End;
  Port[Base+TxR]:=Ord(c);       {Zeichen senden}
End;

Begin
  Open_Port(2);                 {COM ”ffnen}
  Set_Speed(19200);             {Geschwindigkeit 19200 bps}
  Set_Param(8,N,1);             {Parameter setzen}
  WriteLn;
  WriteLn('Terminal in Funktion (Alt-X zum Beenden):');
  Repeat
    Key:=ReadKey;               {Taste lesen}
    If Key <> #0 Then           {normale Tasten an COM-Port senden}
      Transmit(Key)
    Else                        {bei Alt-X beenden}
      If ReadKey=#45 Then fertig:=true;
  Until fertig;
  Close_Port;                   {Interrupts ausschalten}
End.
program rtc_unit;

uses crt,dos;

const
  Rtc_Sekunden        = $00;
  Rtc_Sekunden_alarm  = $01;
  Rtc_Minuten         = $02;
  Rtc_Minuten_alarm   = $03;
  Rtc_Stunden         = $04;
  Rtc_Stunden_alarm   = $05;
  Rtc_Wochentag       = $06;
  Rtc_Tag_des_Monats  = $07;
  Rtc_Monat           = $08;
  Rtc_Jahr            = $09;
  Rtc_Status_A        = $0A;
  Rtc_Status_B        = $0B;
  Rtc_Status_C        = $0C;
  Rtc_Status_D        = $0D;
  Rtc_Diagnose_status = $0E;
  Rtc_Shutdown_status = $0F;
  Rtc_Floppy_Typ      = $10;
  Rtc_HD_Typ          = $12;
  Rtc_Ausstattung     = $14;
  Rtc_Lo_Basememory   = $15;
  Rtc_Hi_Basememory   = $16;
  Rtc_Lo_Extendedmem  = $17;
  Rtc_Hi_Extendedmem  = $18;
  Rtc_HD1_extended    = $19;
  Rtc_HD2_extended    = $1A;
  Rtc_Features        = $1F;
  Rtc_HD1_Lo_Cylinder = $20;
  Rtc_HD1_Hi_Cylinder = $21;
  Rtc_HD1_Koepfe      = $22;
  Rtc_HD1_Lo_Precom   = $23;
  Rtc_HD1_Hi_Precom   = $24;
  Rtc_HD1_Lo_Landing  = $25;
  Rtc_HD1_Hi_Landing  = $26;
  Rtc_HD1_Sektoren    = $27;
  Rtc_Optionen1       = $28;
  Rtc_Optionen2       = $2B;
  Rtc_Optionen3       = $2C;
  Rtc_Lo_Checksumme   = $2E;
  Rtc_Hi_Checksumme   = $2F;
  Rtc_Extendedmem_Lo  = $30;
  Rtc_Extendedmem_Hi  = $31;
  Rtc_Jahrhundert     = $32;
  Rtc_Setup_Info      = $33;
  Rtc_CPU_speed       = $34;
  Rtc_HD2_Lo_Cylinder = $35;
  Rtc_HD2_Hi_Cylinder = $36;
  Rtc_HD2_Koepfe      = $37;
  Rtc_HD2_Lo_Precom   = $38;
  Rtc_HD2_Hi_Precom   = $39;
  Rtc_HD2_Lo_Landing  = $3A;
  Rtc_HD2_Hi_Landing  = $3B;
  Rtc_HD2_Sektoren    = $3C;


function wrhexb(b : byte) : string;
const hexcar : array[0..15] of char =
 ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
begin;
  wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
end;

function wrhexw(w : word) : string;
begin;
  wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
end;

procedure write_rtc(Reg,val : byte);
{
 Schreibt einen Wert in das in Reg angegebene RTC-Register
}
begin;
  port[$70] := Reg;
  port[$71] := val;
end;

function read_rtc(Reg : byte) : byte;
{
 Liest einen Wert aus dem in Reg angegebene RTC-Register
}
begin;
  port[$70] := Reg;
  read_rtc := port[$71];
end;

Procedure Write_Floppy;
{
 Gibt Informationen ber die installierten Floppy-Laufwerke aus
}
Var Fl : byte;
    Fls : array[1..2] of byte;
begin;
  Fl     := Read_Rtc(Rtc_Floppy_Typ);
  Fls[2] := Fl AND $0F;
  Fls[1] := Fl SHR 4;
  for Fl := 1 to 2 do begin;
    write('Floppy ',Fl,': ');
    case Fls[Fl] of
      0 : begin;
            writeln('No  Floppy        ');
          end;
      1 : begin;
            writeln('5¬" Floppy, 360 KB');
          end;
      2 : begin;
            writeln('5¬" Floppy, 1.2 MB');
          end;
      3 : begin;
            writeln('3«" Floppy, 720 KB');
          end;
      4 : begin;
            writeln('3«" Floppy, 1.44 MB');
          end;
    end;
  end;
end;

Procedure Write_Hd;
{
 Gibt den Typ der installierten HDs aus
}
Var Hd : byte;
    Hds : array[1..2] of byte;
begin;
  Hd     := Read_Rtc(Rtc_HD_Typ);
  Hds[2] := Hd AND $0F;
  Hds[1] := Hd SHR 4;
  If HDs[1] = $F then HDs[1] := Read_Rtc(Rtc_HD1_extended);
  If HDs[2] = $F then HDs[2] := Read_Rtc(Rtc_HD2_extended);
  writeln('HD 1 : Typ ',Hds[1]);
  writeln('HD 2 : Typ ',Hds[2]);
end;

procedure Write_Memory;
{
 Gibt den zur Verfgung stehenden Speicher aus
}
var base,extended : word;
begin;
  Base     := 256 * Read_Rtc(Rtc_Hi_Basememory) +
              Read_Rtc(Rtc_Lo_Basememory);
  extended := 256 * Read_Rtc(Rtc_Hi_Extendedmem) +
              Read_Rtc(Rtc_Lo_Extendedmem);
  writeln('Base memory: ',Base,' KB');
  writeln('Exteded memory: ',extended,' KB');
end;

procedure Write_Display;
{
 Gibt den Typ der Grafik-Karte aus und informiert, ob ein Co-Prozessor
 installiert ist
}
var dtyp : byte;
    Copro : byte;
begin;
  dtyp  := Read_Rtc(Rtc_Ausstattung);
  Copro := (dtyp AND 3) SHR 1;
  dtyp  := (dtyp AND 63) SHR 4;
  case dtyp of
    0 : begin;
          writeln('Extended functionality GFX-Controller');
        end;
    1 : begin;
          writeln('Color Display im 40-Spalten Modus');
        end;
    2 : begin;
          writeln('Color Display im 80-Spalten Modus');
        end;
    3 : begin;
          writeln('Monochrome Display Controller');
        end;
  end;
  if Copro = 1 then
    writeln('Co-Prozessor gefunden')
  else
    writeln('Kein Co-Prozessor gefunden');
end;

procedure write_shadow;
{
 Gibt aus, welche Bereiche vom Shadow-Ram untersttzt werden
}
var shadow : byte;
begin;
  shadow := read_rtc(Rtc_Optionen1);
  shadow := shadow AND 3;
  case shadow of
    0 : begin;
          writeln('Shadow System AND Video BIOS');
        end;
    1 : begin;
          writeln('Shadow System BIOS');
        end;
    2 : begin;
          writeln('Shadow disabled');
        end;
  end;
end;

procedure write_cpuspeed;
{
 Gibt an, ob sich die CPU im Turbo-Mode befindet
}
var speed : byte;
begin;
  speed := read_rtc(Rtc_CPU_speed);
  if speed = 1 then
    writeln('CPU in Turbo-Mode')
  else
    writeln('CPU in Deturbo-Mode');
end;

var speed : byte;
begin;
 clrscr;
 Write_Floppy;
 Write_Hd;
 Write_Memory;
 Write_Display;
 Write_Shadow;
 Write_CPUSpeed;
end.




program test_timer;

uses crt,dos;

Var OTimerInt  : pointer;
    Timerfreq    : word;
    Orig_freq    : word;
    Sync_counter : word;
    Tizaehler    : word;

PROCEDURE SetColor (Nr, R, G, B : BYTE);
begin;
  asm
    mov   al,Nr
    mov   dx,03C8h
    out   dx,al
    mov   dx,03C9h
    mov   al,r
    out   dx,al
    mov   al,g
    out   dx,al
    mov   al,b
    out   dx,al
  end;
end;

procedure waitretrace;
begin;
  asm
    MOV   DX,03dAh
@WD_R:
    IN    AL,DX
    TEST  AL,8d
    JZ    @WD_R
@WD_D:
    IN    AL,DX
    TEST  AL,8d
    JNZ   @WD_D
  end;
end;

procedure StelleTimerEin(Proc : pointer; Freq : word);
var izaehler : word;
    oldv : pointer;
begin;
 asm cli end;
 izaehler := 1193180 DIV Freq;
 Port[$43] := $36;
 Port[$40] := Lo(IZaehler);
 Port[$40] := Hi(IZaehler);

 Getintvec(8,OTimerInt);
 SetIntVec(8,Proc);
 asm sti end;
end;

procedure Neue_Timerfreq(Freq : word);
var izaehler : word;
begin;
 asm cli end;
 izaehler := 1193180 DIV Freq;
 Port[$43] := $36;
 Port[$40] := Lo(IZaehler);
 Port[$40] := Hi(IZaehler);
 asm sti end;
end;

procedure StelleTimerAus;
var oldv : pointer;
begin;
  asm cli end;
  port[$43] := $36;
  Port[$40] := 0;
  Port[$40] := 0;
  SetIntVec(8,OTimerInt);
  asm sti end;
end;

procedure Syncro_interrupt; interrupt;
begin;
  inc(Sync_counter);
  port[$20] := $20;
end;

procedure Syncronize_timer;
begin;
  Timerfreq := 120;
  StelleTimerEin(@Syncro_interrupt,Timerfreq);
  Repeat
    dec(Timerfreq,2);
    waitretrace;
    Neue_timerfreq(Timerfreq);
    Sync_counter := 0;
    waitretrace;
  until (Sync_counter = 0);
end;

Procedure Timer_Handling;
begin;
  setcolor(0,0,63,0);
end;

Procedure Timer_Proc; interrupt;
begin;
  Timer_Handling;
  waitretrace;
  Port[$43] := $34;                     { Mono - Flop  Modus }
  Port[$40] := Lo(TiZaehler);
  Port[$40] := Hi(TiZaehler);

  setcolor(0,63,0,0);

  port[$20] := $20;
end;

Procedure Starte_Syncrotimer(Proc : pointer);
var calcl : longint;
begin;
 asm cli end;
  port[$43] := $36;
  Port[$40] := 0;
  Port[$40] := 0;

  Tizaehler := 1193180 DIV (Timerfreq+5);
  setintvec(8,Proc);
  waitretrace;
  Port[$43] := $34;                     { Mono - Flop  Modus }
  Port[$40] := Lo(TiZaehler);
  Port[$40] := Hi(TiZaehler);
 asm sti end;
end;

begin;
  clrscr;
  Syncronize_Timer;
  writeln('Die Timerfrequenz ist : ',Timerfreq);
  Starte_Syncrotimer(@Timer_Proc);
  repeat until keypressed;
  while keypressed do readkey;
  StelleTimerAus;
  setcolor(0,0,0,0);
end.
.286

segment data
w equ word ptr
b equ byte ptr
num_voices equ 14

;**************************************************************************
;***                    D A T E N S E G M E N T                         ***
;**************************************************************************

  gefunden      db ?

;**************************************************************************
;***                      Z U W E I S U N G E N                         ***
;**************************************************************************

  Play_Voice equ 0
  Stop_Voice equ 3
  Bit8       equ 0
  Bit16      equ 4
  No_Loop    equ 0
  Mit_Loop   equ 8
  Unidirect  equ 0
  Bidirect   equ 16
  Go_forw    equ 0
  Go_Back    equ 64
data ends

;**************************************************************************
;***                      C O D E S E G M E N T                         ***
;**************************************************************************

segment code
  assume cs:code, ds:data

;**************************************************************************
;***               P U B L I C  -  D E K L A R A T I O N E N            ***
;**************************************************************************


  u_base     dw 240h
  u_status   dw u_base+006h
  u_voice    dw u_base+102h
  u_command  dw u_base+103h
  u_Datalo   dw u_base+104h
  u_Datahi   dw u_base+105h
  u_DramIO   dw u_base+107h



oldUVolumes dw 01000h,0B000h,0B100h,0B200h,0B300h,0B400h,0B500h,0B600h,0B700h
         dw 0B800h,0B900h,0BA00h,0BB00h,0BC00h,0BD00h,0BE00h,0BF00h
         dw 0C000h,0C100h,0C200h,0C300h,0C400h,0C500h,0C600h,0C700h
         dw 0C800h,0C900h,0CA00h,0CB00h,0CC00h,0CD00h,0CE00h,0CF00h
         dw 0D000h,0D100h,0D200h,0D300h,0D400h,0D500h,0D600h,0D700h
         dw 0D800h,0D900h,0DA00h,0DB00h,0DC00h,0DD00h,0DE00h,0DF00h
         dw 0E000h,0E100h,0E200h,0E300h,0E400h,0E500h,0E600h,0E700h
         dw 0E800h,0E900h,0EA00h,0EB00h,0EC00h,0ED00h,0EE00h,0EF00h


UVolumes  DW 1500h
	DW 40004,42600,44752,45648,46544,47624,48448,49232
	DW 50048,50584,51112,51656,52184,52584,52976,53376
	DW 53752,54016,54280,54520,54768,55024,55280,55544
	DW 55776,56048,56288,56536,56784,56992,57184,57384
	DW 57616,57752,57888,58000,58112,58248,58368,58480
	DW 58600,58720,58840,58960,59088,59208,59336,59464
	DW 59584,59720,59816,59944,60072,60176,60312,60408
	DW 60544,60648,60784,60888,60992,61064,61176,61248


Voice_Divisor db 43,40,37,35,33,31,30,28,27,26,25,24,23,22,21,20,20,19,18

FFtable dw   66,   70,   74,   78,   83,   88,   93,   99,  104,  111
        dw  117,  124,  132,  139,  148,  156,  166,  176,  186,  197
        dw  209,  221,  234,  248,  263,  279,  295,  313,  331,  351
        dw  372,  394,  418,  442,  469,  497,  526,  557,  591,  626
        dw  663,  702,  744,  788,  835,  885,  938,  993, 1052, 1115
        dw 1181, 1251, 1326, 1405, 1488, 1577, 1671, 1770, 1875, 1987
        dw 2105, 2230, 2362, 2503, 2652, 2809, 2977, 3154, 3341, 3540


Modoktave  dw 1712,1616,1525,1440,1359,1283,1211
           dw 1143,1078,961,907,856,808,763,720
           dw 679,641,605,571,539,509,480,453,428
           dw 404,381,360,340,321,303,286,270,254
           dw 240,227,214,202,191,180,170,160,151
           dw 143,135, 127,120,113,107,101,95,90
           dw 85,80,76,71,67,64,60,57,54,50,47,45
           dw 42,40,38,36,34,32,30

public U_StartVoice
public u_VoiceBalance
public u_VoiceVolume
public u_delay
public u_Initialize
public u_Voicefreq
public Ultra_Mem2Gus
public u_Voicedata
public ffaktor
public Notennr
public dos_getmem
public dos_freemem
public detect_gus
public init_gus_base
public GusSound_ein
public GusSound_aus
public voice_rampin
public voice_slidein

u_delay proc pascal
; **************************************************************************
; *** Wartet die fr Double-writes ben”tigte Zeit                        ***
; **************************************************************************
  mov dx,300h
  in al,dx
  in al,dx
  in al,dx
  in al,dx
  in al,dx
  in al,dx
  in al,dx
  ret
u_delay endp

U_StartVoice proc pascal Nr,Modus : byte
; **************************************************************************
; *** Startet die Ausgabe auf einem GUS-Kanal                            ***
; **************************************************************************
  mov dx,w u_voice                ; Stimme w„hlen
  mov al,byte ptr Nr
  out dx,al
  mov dx,w u_command
  mov al,0                        ; Voice Mode
  out dx,al
  mov dx,w u_DataHi
  mov al,Modus                    ; MODUS Byte setzen
  out dx,al
  ret
U_StartVoice endp

u_VoiceBalance proc pascal Nr,balance : byte
; **************************************************************************
; *** Stellt die Pan-Position fr einen Kanal ein (0 - 15)               ***
; **************************************************************************
  mov dx,w u_Voice                ; Stimme w„hlen
  mov al,byte ptr Nr
  out dx,al
  mov dx,w u_Command              ; Befehl Set Pan-Position
  mov al,0Ch
  out dx,al
  mov dx,w u_dataHi               ; Position schreiben
  mov al,balance
  out dx,al
  ret
u_VoiceBalance endp

u_VoiceVolume proc pascal Nr:byte,Vol:word
; **************************************************************************
; *** Stellt die Lautst„rke fr einen Kanal ein  (0 - 63)                ***
; **************************************************************************
    mov dx,w u_Voice              ; Stimme w„hlen
    mov al,Nr
    out dx,al
    mov dx,w u_Command            ; Befehl Lautst„rke setzen
    mov al,9
    out dx,al
    mov dx,w u_DataLo             ; GUS-Lautst„rke aus Tabelle laden
    mov di,vol                    ; und setzen
    shl di,1
    mov ax,word ptr [offset uVolumes + di]
    out dx,ax
    ret
u_VoiceVolume  endp

u_Initialize proc near
; **************************************************************************
; *** Initialisiert die Ultrasound                                       ***
; **************************************************************************
  mov bx,w u_Command
  mov cx,w u_datahi
  mov dx,bx
  mov al,4ch                      ; Init - Register w„hlen
  out dx,al
  mov dx,cx
  mov al,0                        ; Init durchfhren
  out dx,al
  call u_delay                    ; warten
  call u_delay
  mov dx,bx
  mov al,4ch
  out dx,al
  mov dx,cx
  mov al,1                        ; Init beenden
  out dx,al
  call u_delay
  call u_delay
  mov dx,bx                       ; DMA Control Register resetten
  mov al,41h
  out dx,al
  mov dx,cx
  mov al,0
  out dx,al
  mov dx,bx                       ; Timer Control Register resetten
  mov al,45h
  out dx,al
  mov dx,cx
  mov al,0
  out dx,al
  mov dx,bx                       ; Sampling Control Register resetten
  mov al,49h
  out dx,al
  mov dx,cx
  mov al,0
  out dx,al
  mov dx,bx                       ; Anzahl Stimmen setzen
  mov al,0Eh
  out dx,al
  add dx,2
  mov al,Num_Voices
  or  al,0C0h
  out dx,al
  mov dx,w u_status               ; Evtl. DMA Interrupts leeren
  in al,dx
  mov dx,bx
  mov al,41h
  out dx,al
  mov dx,cx
  in al,dx
  mov dx,bx                       ; Evtl. Sampling Interrupts leeren
  mov al,49h
  out dx,al
  mov dx,cx
  in al,dx
  mov dx,bx                       ; IRQ Status Register lesen
  mov al,8Fh                      ; ==> Es liegen jetzt keine unbearbeiteten
  out dx,al                       ;     Interrupts an
  mov dx,cx
  in al,dx
  push bx                         ; In Schleife die Stimmen ausschalten
  push cx
  mov cx,0
@VoiceClearLoop:
  mov dx,w u_Voice                ; Stimme w„hlen
  mov al,cl
  out dx,al
  inc dx
  mov al,0                        ; Voice Modus setzen
  out dx,al
  add dx,2
  mov al,3                        ; Stimme stoppen
  out dx,al
  sub dx,2                        ; Lautst„rke auf 0 setzen
  mov al,0dh
  out dx,al
  add dx,2
  mov al,3
  out dx,al
  inc cx
  cmp cx,32                       ; fr alle Stimmen wiederholen
  jnz @VoiceClearLoop
  pop cx
  pop bx
  mov dx,bx                       ; Eventuell aufgetretene Interrupts
  mov al,41h                      ; "abarbeiten"
  out dx,al
  mov dx,cx
  in al,dx
  mov dx,bx
  mov al,49h
  out dx,al
  mov dx,cx
  in al,dx
  mov dx,bx
  mov al,8fh
  out dx,al
  mov dx,cx
  in al,dx
  mov dx,bx                       ; Reset durchfhren
  mov al,4ch
  out dx,al
  mov dx,cx                       ; GF1 Master IRQ einschalten
  mov al,7
  out dx,al
  ret
u_Initialize endp

u_Voicefreq proc pascal Nr:byte,Freq:word
; **************************************************************************
; *** Stellt die Frequenz ein, mit der der Kanal abgespielt wird         ***
; **************************************************************************
  mov dx,w u_Voice                ; Stimme adressieren
  mov al,Nr
  out dx,al
  mov dx,w u_Command              ; Befehl Voicefreqenz schreiben
  mov al,1
  out dx,al                       ; Freq := Freqenz DIV
  xor bx,bx                       ;         Voice_Divisor[num_voices-13]
  mov bl,num_voices
  mov ax,Freq
;  mov di,bx
;  sub di,14
;  xor bx,bx
;  xor dx,dx
;  mov bl,byte ptr [voice_Divisor+di]
;  div bx
  mov dx,w u_DataLo
  out dx,ax
  ret
u_Voicefreq endp


Ultra_Mem2Gus proc pascal sampp:dword,start:dword,laenge:word
; **************************************************************************
; *** Kopiert einen Speicherbereich aus dem RAM ins GUS-Ram              ***
; **************************************************************************
    push ds
    push si
    mov si,[bp+12]                ; Segment
    mov ds,si
    mov si,[bp+10]                ; Offset
    mov dx,w u_Command            ; Hi-Byte der GUS-DRAM Adresse setzen
    mov al,44h
    out dx,al
    mov dx,w u_DataHi
    mov ax,[bp+08]                ; hstart
    out dx,al
    mov cx,[bp+4]                 ; L„nge laden
@Copy_loop:
    mov dx,w u_Command            ; Lo-Byte der GUS-DRAM Adresse setzen
    mov al,43h
    out dx,al
    mov dx,w u_DataLo
    mov ax,[bp+06]                ; lstart
    out dx,ax
    mov dx,w u_DramIo             ; Byte laden und ausgeben
    lodsb
    out dx,al
    cmp word ptr [bp+06],0ffffh   ; lstart = 0ffffh ?
    je @ueberlauf
    inc word ptr [bp+06]          ; lstart++
    jmp @weiter
@ueberlauf:
    inc word ptr [bp+08]          ; hstart ++
    mov word ptr [bp+06],0        ; lstart auf 0
    mov dx,w u_Command            ; Hi-Byte der GUS-DRAM Adresse setzen
    mov al,44h
    out dx,al
    mov dx,w u_DataHi
    mov ax,[bp+08]                ; hstart
    out dx,al
@weiter:
    loop @copy_loop
    pop si
    pop ds
    ret
Ultra_Mem2Gus endp

u_Voicedata proc pascal start,lsta,llaenge:dword,Nr:word
; **************************************************************************
; *** Setzt die Partameter fr einen Kanal                               ***
; **************************************************************************
    mov dx,w u_Voice              ; Stimme w„hlen
    mov ax,Nr
    out dx,al
    mov dx,w u_command            ; Stimmenanfang setzen
    mov al,0ah
    out dx,al
    mov ax, word ptr [start+2]
    mov cx, word ptr [start]
    mov bx,cx
    shr ax,7
    shr cx,7
    shl bx,9
    or  ax,bx
    mov dx,w u_DataLo
    out dx,ax
    mov dx,w u_Command
    mov al,0bh
    out dx,al
    mov dx,w u_datalo
    mov ax,word ptr [start]
    shl ax,9
    out dx,ax
    mov dx,w u_command            ; Loop-Start setzen
    mov al,2
    out dx,al
    mov ax, word ptr [lsta]
    mov cx, word ptr [lsta+2]
    mov bx,cx
    shr ax,7
    shr cx,7
    shl bx,9
    or  ax,bx
    mov dx,w u_DataLo
    out dx,ax
    mov dx,w u_Command
    mov al,3
    out dx,al
    mov dx,w u_datalo
    mov ax,word ptr [lsta]
    shl ax,9
    out dx,ax
    mov dx,w u_command            ; Loop-Ende setzen
    mov al,4
    out dx,al
    mov ax, word ptr [llaenge]
    mov cx, word ptr [llaenge+2]
    mov bx,cx
    shr ax,7
    shr cx,7
    shl bx,9
    or  ax,bx
    mov dx,w u_DataLo
    out dx,ax
    mov dx,w u_Command
    mov al,5
    out dx,al
    mov dx,w u_datalo
    mov ax,word ptr [llaenge]
    shl ax,9
    out dx,ax
   ret
u_Voicedata endp

ffaktor proc pascal t:word
; **************************************************************************
; ***  Liefert die Frequenz des in "t" bergebenen Tons                  ***
; **************************************************************************
 mov di,t
 sub di,5
 shl di,1
 mov ax,word ptr [offset fftable+di]
 ret
ffaktor endp

Notennr proc pascal hoehe:word
; **************************************************************************
; *** Bestimmt die Nummer der Note ber die "hoehe" des Tons aus der     ***
; *** MOD-Datei                                                          ***
; **************************************************************************
  mov gefunden,1
  xor di,di
@schleife:
  mov ax,word ptr Modoktave[di]
  cmp hoehe,ax
  ja note_gefunden
  add di,2
;  cmp di,128
  cmp di,140
  jae @weiter_arbeiten
  jmp @schleife
note_gefunden:
  mov gefunden,0
@weiter_arbeiten:
  mov ax,255
  cmp gefunden,0
  jne Ende_Notennr
  mov ax,di
  shr ax,1
  inc ax
Ende_Notennr:
  ret
Notennr endp

dos_getmem proc pascal zeiger:dword,menge:word
; **************************************************************************
; *** Allociert einen (max. 64 KB grosen) Speicherbereich im DOS-Ram     ***
; **************************************************************************
  push ds
  mov bx,menge
  shr bx,4
  inc bx
  mov ah,48h
  int 21h
  mov bx,w [zeiger+2]
  mov ds,bx
  mov bx,w [zeiger]
  mov w [bx],0
  mov w [bx+2],ax
  pop ds
  ret
dos_getmem endp

dos_freemem proc pascal zeiger:dword
; **************************************************************************
; *** Gibt einen ber dos_getmem allocierten Bereich wieder frei         ***
; **************************************************************************
  mov ax,word ptr [zeiger+2]
  mov es,ax
  mov ah,49h
  int 21h
  ret
dos_freemem endp

detect_gus proc near
; **************************************************************************
; *** Die Routine dient zur Erkennung der Gravis Ultrasound. Der Base-   ***
; *** Port wird erkannt. Die Funktion liefert 0, wenn die Karte gefunden ***
; *** wurde, ansonsten 1.                                                ***
; **************************************************************************
  mov di,1F0h
@detect_loop:                     ; In einer Schleife m”gliche Ports testen
  add di,10h
  mov dx,di
  add dx,103h                     ; Initialisierung versuchen
  mov al,4Ch
  out dx,al
  mov dx,di
  add dx,105h
  mov al,0
  out dx,al ;?????
  call u_delay
  call u_delay
  mov dx,di
  add dx,103h
  mov al,4Ch
  out dx,al
  mov dx,di
  add dx,105h
  mov al,1
  out dx,al ;????
  mov dx,di                       ; Versuchen, Daten in das GUS-Ram zu
  add dx,103h                     ; schreiben
  mov al,43h
  out dx,al
  mov dx,di
  add dx,105h
  mov al,0h
  out dx,al
  mov dx,di
  add dx,103h
  mov al,44h
  out dx,al
  mov dx,di
  add dx,105h
  mov al,0h
  out dx,al
  mov dx,di
  add dx,107h
  mov al,0AAh
  out dx,al
  call u_delay                    ; entsprechend warten, damit uns der GF1
  call u_delay                    ; nicht dazwischen pfuschen kann
  call u_delay
  call u_delay
  call u_delay
  call u_delay
  xor ax,ax                       ; Wert aus GUS-Ram zurcklesen
  mov dx,di
  add dx,107h
  in  al,dx
  cmp al,0AAh                     ; Gelesener Wert = geschriebenem Wert ?
  je  @Karte_gefunden             ; Juhuuuu, Karte gefunden !
  cmp di,280h
  jae @Karte_nicht_gefunden       ; Keine Karte an den Ports zu finden  :(
  jmp @detect_loop                ; Neuen Port versuchen
@Karte_gefunden:
  mov w u_base,di                 ; Basisregister der Karte initialisieren
  mov ax,di
  add ax,6
  mov w u_status,ax
  mov ax,di
  add ax,102h
  mov w u_voice,ax
  mov ax,di
  add ax,103h
  mov w u_command,ax
  mov ax,di
  add ax,104h
  mov w u_Datalo,ax
  mov ax,di
  add ax,105h
  mov w u_Datahi,ax
  mov ax,di
  add ax,107h
  mov w u_DramIO,ax
  mov ax,0
  jmp @Ende_Kartenerkennung
@Karte_nicht_gefunden:
  mov ax,1
@Ende_Kartenerkennung:
  ret
detect_gus endp

init_gus_base proc pascal gbase : word;
; **************************************************************************
; *** Die Routine dient zur Erkennung der Gravis Ultrasound. Der Base-   ***
; *** Port wird erkannt. Die Funktion liefert 0, wenn die Karte gefunden ***
; *** wurde, ansonsten 1.                                                ***
; **************************************************************************
  mov di,gbase
  mov dx,di
  add dx,103h                     ; Initialisierung versuchen
  mov al,4Ch
  out dx,al
  mov dx,di
  add dx,105h
  mov al,0
  out dx,al ;?????
  call u_delay
  call u_delay
  mov dx,di
  add dx,103h
  mov al,4Ch
  out dx,al
  mov dx,di
  add dx,105h
  mov al,1
  out dx,al ;????

  mov w u_base,di                 ; Basisregister der Karte initialisieren
  mov ax,di
  add ax,6
  mov w u_status,ax
  mov ax,di
  add ax,102h
  mov w u_voice,ax
  mov ax,di
  add ax,103h
  mov w u_command,ax
  mov ax,di
  add ax,104h
  mov w u_Datalo,ax
  mov ax,di
  add ax,105h
  mov w u_Datahi,ax
  mov ax,di
  add ax,107h
  mov w u_DramIO,ax
  mov ax,0
  ret
init_gus_base endp


GusSound_aus proc near
; **************************************************************************
; *** Schaltet die Sound-Ausgabe der GUS aus                             ***
; **************************************************************************
  mov dx,w u_base
  in  al,dx
  or  al,2
  out dx,al
  ret
GusSound_aus endp

GusSound_ein proc near
; **************************************************************************
; *** Schaltet die Sound-Ausgabe (Wavetabel) der GUS ein.                ***
; **************************************************************************
  mov dx,w u_base
  in  al,dx
  and al,0FDh
  out dx,al
  ret
GusSound_ein endp

voice_rampin proc pascal Stimme:byte,vol : word;
; **************************************************************************
; *** Eine Alternative zum dirketen Setzen der Lautst„rke einer Stimme.  ***
; *** Der Player verliert etwas an Agressivit„t, jedoch wird evtl.       ***
; *** Knacken erheblich reduziert.                                       ***
; **************************************************************************
  mov dx,w u_voice                ; Stimme w„hlen
  mov al,byte ptr Stimme
  out dx,al
  mov dx,w u_command              ; Ramping-Faktor setzen
  mov al,6
  out dx,al
  mov dx,w u_datahi
  mov al,00111111b
  out dx,al
  mov dx,w u_Command              ; Aktuelle Lautst„rke anpassen
  mov al,9
  out dx,al
  mov dx,w u_datahi
  mov al,00010010b
  out dx,al
  mov dx,w u_command              ; Ramping Start-Lautst„rke setzen
  mov al,7
  out dx,al
  mov dx,w u_datahi
  mov al,00010010b
  out dx,al
  mov dx,w u_command              ; Ramping End-Lautst„rke setzen
  mov al,8
  out dx,al
  mov dx,w u_datahi
  mov di,word ptr vol
  shl di,1
  mov ax,word ptr [offset uVolumes + di]
  shr ax,8
  out dx,al
  mov dx,w u_command              ; Ramping Richtung im Volume Control
  mov al,0dh                      ; Register setzen
  out dx,al
  mov dx,w u_datahi
  mov al,0
  out dx,al
  ret
voice_rampin endp

voice_slidein proc pascal nr,speed : byte,vol : word;
  mov dx,w u_voice                ; Stimme w„hlen
  mov al,byte ptr nr
  out dx,al
  mov dx,w u_command              ; Ramping-Faktor setzen
  mov al,6
  out dx,al
  mov dx,w u_datahi
  mov al,byte ptr speed
  out dx,al
  mov dx,w u_Command              ; Aktuelle Lautst„rke anpassen
  mov al,9
  out dx,al
  mov dx,w u_datahi
  mov al,00010010b
  out dx,al
  mov dx,w u_command              ; Ramping Start-Lautst„rke setzen
  mov al,7
  out dx,al
  mov dx,w u_datahi
  mov al,00010010b
  out dx,al
  mov dx,w u_command              ; Ramping End-Lautst„rke setzen
  mov al,8
  out dx,al
  mov dx,w u_datahi
  mov di,word ptr vol
  shl di,1
  mov ax,word ptr [offset uVolumes + di]
  shr ax,8
  out dx,al
  mov dx,w u_command              ; Ramping Richtung im Volume Control
  mov al,0dh                      ; Register setzen
  out dx,al
  mov dx,w u_datahi
  mov al,0
  out dx,al
  ret
voice_slidein endp

public gus_speaker_on
gus_speaker_on proc pascal
  mov dx,u_base
  mov al,4
  out dx,al
  ret
gus_speaker_on endp

public get_stimmenposition
get_stimmenposition proc pascal stimme : word
  mov dx,w u_command
  mov al,4
  out dx,al
  mov dx,w u_datahi
  in  ax,dx
  mov cx,ax

  ret
get_stimmenposition endp

public get_detected_base
get_detected_base proc pascal
  mov ax,u_base
  ret
get_detected_base endp

code ends
end

unit design;

interface
uses crt,windos;

procedure writexy(x,y : integer;s : string);
procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
function wrhexb(b : byte) : string;
function wrhexw(w : word) : string;
procedure save_screen;
procedure restore_screen;
Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
procedure cursor_On;
procedure cursor_Off;

var filenames : array[1..512] of string[12];
const      Screen_Akt   : byte = 1;


implementation

procedure writexy(x,y : integer;s : string);
begin;
 gotoxy(x,y);
 write(s);
end;

procedure save_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt <= 4 then begin;
    inc(Screen_Akt);
    move(screen[1],screen[Screen_Akt],8000);
  end;
end;

procedure restore_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt >= 2 then begin;
    move(screen[Screen_Akt],screen[1],8000);
    dec(Screen_Akt);
  end;
end;

procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
const frames : array[1..2,1..6] of char =
 (('Ú','¿','Ù','À','Ä','³'),
  ('É','»','¼','È','Í','º'));
var lx,ly : integer;
    s : string;
begin;
  { obere Zeile }
  s := frames[rt,1];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,2];
  gotoxy(startx,starty);
  write(s);
  { mittleren Zeilen }
  for ly := 1 to dy-2 do begin;
    s := frames[rt,6];
    for lx := 1 to dx-2 do s := s + ' ';
    s := s + frames[rt,6];
    gotoxy(startx,starty+ly);
    write(s);
  end;
  { untere Zeile }
  s := frames[rt,4];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,3];
  gotoxy(startx,starty+dy-1);
  write(s);
end;

Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
var tlaeng : byte;
    deltx,tstartpos : byte;
begin;
  tlaeng := length(s);
  tstartpos := x + ((dx-Tlaeng) SHR 1);
  textcolor(rcol);
  textbackground(bcol);
  rahmen(1,x,y,dx,dy);
  writexy(tstartpos,y,s);
end;

procedure sort_filenames(start,ende : integer);
{
 Hier sollte fr gr”áere Verzeichnise Quick-Sort eingebaut werden !
}
var hilfe : string;
    l1,l2 : integer;
begin;
  for l1 := start to ende-1 do begin;
    for l2 := start to ende-1 do begin;
      if filenames[l2] > filenames[l2+1] then begin;
        hilfe := filenames[l2];
        filenames[l2] := filenames[l2+1];
        filenames[l2+1] := hilfe;
      end;
    end;
  end;
end;

function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
const  zeile : byte = 1;
  spalte : byte = 0;
  Start_fndisp : word = 0;
var
  DirInfo: TSearchRec;
  count : integer;
  Nullpos : byte;
var li,lj : integer;
    inp : char;
    retval : string;
    kasten_gefunden : boolean;
    select : byte;
    changed : boolean;
    End_fndisp : word;
begin
  {$I+}
  for li := 1 to 512 do filenames[li] := ' - - -';
  count := 1;
  FindFirst(mask, faArchive, DirInfo);
  while DosError = 0 do
  begin
    filenames[count] := (DirInfo.Name);
    Nullpos := pos(#0,filenames[count]);
    if Nullpos <> 0 then
      filenames[count] := copy(filenames[count],0,Nullpos-1);
    inc(count);
    FindNext(DirInfo);
  end;
  {$I-}

  sort_filenames(1,count-1);
  save_screen;
  Fenster(5,4,72,16,comment,black,7);
  textcolor(1);
  writexy(21,5,'         Bitte Datei ausw„hlen');
  textcolor(black);
  inp := #255;
  changed := true;
  repeat
    textcolor(black);
    if changed then begin;
      changed := false;
      for lj := 0 to 4 do begin;
        for li := 1 to 12 do begin;
          writexy(7+lj*14,5+li,'            ');
          writexy(7+lj*14,5+li,filenames[lj*12+li+Start_fndisp]);
        end;
      end;
      textcolor(14);
      writexy(7+Spalte*14,5+Zeile,filenames[Spalte*12+Zeile+Start_fndisp]);
    end;
    if keypressed then inp := readkey;
    if ord(inp) = 0 then inp := readkey;
    case ord(inp) of
      32,
      13: begin;
            inp := #13;
            changed := true;
            if (pos('- - -',filenames[Spalte*12+Zeile+Start_fndisp]) = 0) then
              retval := filenames[Spalte*12+Zeile+Start_fndisp]
            else
              retval := 'xxxx';
          end;
      27: begin;
            inp := #27;
            changed := true;
            retval := 'xxxx';
          end;
      71: begin; { Pos 1 }
            inp := #255;
            Zeile  := 1;
            Spalte := 0;
            changed := true;
          end;
      72: begin; { Pfeil up }
            inp := #255;
            changed := true;
            if not ((Zeile = 1) and (Spalte = 0)) then
              dec(Zeile);
            if Zeile = 0 then begin;
              dec(Spalte);
              Zeile := 12;
            end;
          end;
      73: begin; { Page UP }
            if Start_fndisp >= 12 then
              dec(Start_fndisp,12)
            else begin;
              Start_fndisp := 0;
              Zeile := 1;
            end;
            inp := #255;
            changed := true;
          end;
      81: begin; { Page Down }
            if ((Spalte+1)*12+Start_fndisp < count) and
            (Start_fndisp < 500) then
              inc(Start_fndisp,12)
            else
              Start_fndisp := count-11;
            inp := #255;
            changed := true;
          end;
      75: begin; { Pfeil links }
            inp := #255;
            changed := true;
            if Spalte = 0 then begin;
              if Start_fndisp >= 12 then dec(Start_fndisp,12);
            end else begin;
              if Spalte > 0 then dec(Spalte);
            end;
          end;
      77: begin; { Pfeil rechts }
            inp := #255;
            changed := true;
            if Spalte = 4 then begin;
              if ((Spalte+1)*12+Start_fndisp < count) and
              (Start_fndisp < 500) then inc(Start_fndisp,12);
            end else begin;
            if (Spalte < 4) and
              (Zeile+(Spalte+1)*12+Start_fndisp < count) then
                inc(Spalte);
            end;
          end;
      79: begin; { End }
            inp := #255;
            changed := true;
            Spalte := (count-Start_fndisp-12) div 12;
            Zeile := (count-Start_fndisp) - Spalte*12 -1;
          end;
      80: begin; { Pfeil down }
            inp := #255;
            changed := true;
            if ((Zeile = 12) and (Spalte = 4)) then begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then begin;
                inc(Start_fndisp,1);
              end;
            end else begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then
                inc(Zeile);
             end;
            if Zeile > 12 then begin;
              inc(Spalte);
              Zeile := 1;
            end;
          end;
      82 : begin;
            changed := true;
             save_screen;
             textcolor(black);
             rahmen(2,16,9,45,5);
             writexy(20,10,' Dateinamen eingeben ('+mtext+')');
             writexy(20,12,'Name: ');
             readln(retval);
             if retval = '' then retval := 'xxxx';
             restore_screen;
           end;
     end;
  until (inp = #13) or (inp = #27) or (inp = #32)
     or (inp = #82);
  restore_screen;
  textbackground(black);
  textcolor(7);
  select_datei := retval;
end;

function wrhexb(b : byte) : string;
const hexcar : array[0..15] of char =
 ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
begin;
  wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
end;

function wrhexw(w : word) : string;
begin;
  wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
end;

procedure cursor_Off; assembler;
asm
  xor ax,ax
  mov ah,01h
  mov cx,2020h
  int 10h
end;

procedure cursor_on; assembler;
asm
 mov ah,01h
 mov cx,0607h
 int 10h
end;



begin;
end.unit fselect;

interface

type
  t = record
       c : char;
       a : byte;
     end;

  Pfileselect_struct = ^Tfileselect_struct;
  Tfileselect_struct = record
     sx,sy   : integer;
     Path    : string;
     Mask    : string;
     Tietel  : string[25];
     fn      : array[1..30] of string [80];
     nofiles : integer;
   end;

   Pdateilist = ^Tdateilist;
   TDateilist = array[0..511] of string[12];

   Ppfadliste = ^Tpfadliste;
   TPfadliste = array[0..511] of string[80];

   Psizeliste = ^Tsizeliste;
   Tsizeliste = array[0..511] of longint;

   Pselectliste = ^Tselectliste;
   Tselectliste = array[0..511] of boolean;

   PAttribliste = ^TAttribliste;
   Tattribliste = array[0..511] of byte;


procedure select_packdateien(fs : Pfileselect_struct);
procedure display_ansi(p :pointer; mode : word);

var screen : array[1..50,1..80] of t absolute $B800:$0000;

implementation

uses dos,design,crt;

var fnames         : PDateilist;
    fpfad          : PPfadliste;
    fsize          : PSizeliste;
    fselected      : PSelectliste;
    fattrib        : PAttribliste;

    dnames         : PDateilist;
    dsize          : PSizeliste;
    dselected      : PSelectliste;
    dattrib        : PAttribliste;

     Start_Anzeige  : integer;
    Cursor_Zeile   : integer;
    selectcount    : word;
    bytes_selected : longint;

var DirInfo: SearchRec;
    li : integer;
    count,
    fcount,
    dcount: integer;
    Nullpos : byte;
    ch : char;
    fscount : integer;
    curdir : string;
    savepath : string;
    marker : pointer;


{$L Fsel }
procedure fsel; external;

procedure waitretrace;
begin;
  asm
    MOV   DX,03dAh
@WD_R:
    IN    AL,DX
    TEST  AL,8d
    JZ    @WD_R
@WD_D:
    IN    AL,DX
    TEST  AL,8d
    JNZ   @WD_D
  end;
end;

procedure display_ansi(p :pointer; mode : word);
begin;
  textmode(mode);
  move(p^,ptr($b800,0)^,8000);
end;


procedure sort_filenames(start,ende : integer);
{
 Hier sollte fr gr”áere Verzeichnise Quick-Sort eingebaut werden !
}
var hilfe : string;
    hsize : longint;
    l1,l2 : integer;
begin;
  for l1 := start to ende-1 do begin;
    for l2 := start to ende-1 do begin;
      if fnames^[l2] > fnames^[l2+1] then begin;
          hilfe := fnames^[l2];
          fnames^[l2] := fnames^[l2+1];
          fnames^[l2+1] := hilfe;

          hsize        := fsize^[l2];
          fsize^[l2]   := fsize^[l2+1];
          fsize^[l2+1] := hsize;

          hsize           := fattrib^[l2];
          fattrib^[l2]    := fattrib^[l2+1];
          fattrib^[l2+1]  := hsize;
        end;
      end;
    end;
end;


procedure sort_dirnames(start,ende : integer);
{
 Hier sollte fr gr”áere Verzeichnise Quick-Sort eingebaut werden !
}
var hilfe : string;
    hsize : longint;
    l1,l2 : integer;
begin;
  for l1 := start to ende-1 do begin;
    for l2 := start to ende-1 do begin;
      if dnames^[l2] > dnames^[l2+1] then begin;
          hilfe := dnames^[l2];
          dnames^[l2] := dnames^[l2+1];
          dnames^[l2+1] := hilfe;

          hsize        := dsize^[l2];
          dsize^[l2]   := dsize^[l2+1];
          dsize^[l2+1] := hsize;

          hsize           := dattrib^[l2];
          dattrib^[l2]    := dattrib^[l2+1];
          dattrib^[l2+1]  := hsize;
        end;
      end;
    end;
end;


procedure draw_files(sx,sy : integer; fs : Pfileselect_struct);
var li : integer;
begin;
   waitretrace;

   textcolor(7);
   textbackground(black);
   for li := 1 to 11 do begin;
     fillchar(screen[sy+li,20].c,100,0);
     gotoxy(sx+2,sy+li);
     if fselected^[Start_Anzeige+li] then begin;
       write('û ');
     end else begin;
       write('  ');
     end;
     write(fnames^[Start_Anzeige+li]);
     while wherex < sx+2+16 do write(' ');
     if (fattrib^[Start_Anzeige+li] and $10) = $10 then begin;
       write('        DIR  ');
     end else begin;
       write(fsize^[Start_Anzeige+li]:7,' Bytes');
     end;
   end;

   move(marker^,screen[sy+Cursor_Zeile,20].c,100);

   textcolor(5); textbackground(black);
   gotoxy(sx+2,sy+Cursor_Zeile);
   if fselected^[Start_Anzeige+Cursor_Zeile] then begin;
     write('û ');
   end else begin;
     write('  ');
   end;
   write(fnames^[Start_Anzeige+Cursor_Zeile]);
   while wherex < sx+2+16 do write(' ');
   if (fattrib^[Start_Anzeige+Cursor_Zeile] and $10) = $10 then begin;
     write('        DIR  ');
   end else begin;
     write(fsize^[Start_Anzeige+Cursor_Zeile]:7,' Bytes');
   end;
end;

procedure append_dirnames(anzahl : word);
var li : integer;
begin;
  for li := 1 to anzahl do begin;
    fnames^[fcount+li-1] := dnames^[li];
    fsize^[fcount+li-1] := dsize^[li];
    fattrib^[fcount+li-1] := dattrib^[li];
  end;
end;


procedure read_directory(fs : Pfileselect_struct);
var curpath : string;
begin;
  {$I+}
  for li := 0 to 511 do fnames^[li]  := ' - - -';
  for li := 0 to 511 do fsize^[li]   := 0;
  for li := 0 to 511 do fattrib^[li] := 0;
  for li := 0 to 511 do dattrib^[li] := 0;
  for li := 0 to 511 do dnames^[li]  := ' - - -';
  for li := 0 to 511 do dsize^[li]   := 0;

  fcount := 1;
  dcount := 1;

  FindFirst(fs^.mask,255, DirInfo);
  while DosError = 0 do
  begin
    if ((DirInfo.attr and $10) = $10) then begin;
      dattrib^[dcount] := DirInfo.attr;
      dnames^[dcount]  := DirInfo.Name;
      dsize^[dcount]   := DirInfo.size;
      Nullpos := pos(#0,dnames^[dcount]);
      if Nullpos <> 0 then
        dnames^[dcount] := copy(dnames^[dcount],0,Nullpos-1);
      inc(dcount);
    end else begin;
      fattrib^[fcount] := DirInfo.attr;
      fnames^[fcount]  := DirInfo.Name;
      fsize^[fcount]   := DirInfo.size;
      Nullpos := pos(#0,fnames^[fcount]);
      if Nullpos <> 0 then
        fnames^[fcount] := copy(fnames^[fcount],0,Nullpos-1);
      inc(fcount);
    end;
    FindNext(DirInfo);
  end;
  {$I-}
  sort_filenames(1,fcount-1);
  sort_dirnames(1,dcount-1);
  append_dirnames(dcount);

  getdir(0,curpath);
  count := fcount + dcount - 1;

  for li := 0 to 511 do fselected^[li] := false;
  for li := 0 to 511 do dselected^[li] := false;
  for li := 0 to 511 do fpfad^[li] := curpath;

 Start_Anzeige := 0;
 Cursor_Zeile  := 1;
end;

procedure neu_einlesen(fs : Pfileselect_struct);
begin;
  read_directory(fs);
  draw_files(fs^.sx,fs^.sy,fs);
  selectcount := 0;
end;

procedure shorten_direntry(fs : Pfileselect_struct);
var last_slashpos : integer;
    hs : string;
begin;
  hs := '';
  while pos('\',fs^.path) <> 0 do begin;
    last_slashpos := pos('\',fs^.path);
    hs := hs+copy(fs^.path,1,last_slashpos);
    delete(fs^.path,1,last_slashpos);

   gotoxy(1,23);
   write('                                                            ');
   gotoxy(1,23);
   write(fs^.path);

  end;
  if hs[length(hs)] = '\' then hs := copy(hs,1,length(hs)-1);
  fs^.path := hs;
  gotoxy(1,23);
  write('                                                            ');
  gotoxy(1,23);
  write(hs);
end;

procedure get_liner;
begin;
  getmem(marker,100);
  move(screen[13,20].c,marker^,100);
end;

procedure select_packdateien(fs : Pfileselect_struct);
var auswahl_beenden : boolean;
    nextpath : string;
begin;
  new(fnames);
  new(fsize);
  new(fselected);
  new(fpfad);
  new(fattrib);

  new(dnames);
  new(dsize);
  new(dselected);
  new(dattrib);

  getdir(0,savepath);
  chdir(fs^.path);

  display_ansi(@fsel,co80);
  get_liner;
  cursor_off;

  inc(fs^.sy,2);

  read_directory(fs);

 ch := #0;
 draw_files(fs^.sx,fs^.sy,fs);
 auswahl_beenden := false;
 while not auswahl_beenden do begin;
   ch := readkey;
   if ch = #0 then ch := readkey;
   case ch of
     #13,
     #27 : begin;
             if (fattrib^[Start_Anzeige+Cursor_Zeile] and $10 = 10)
             then begin;
               nextpath := fnames^[Start_Anzeige+Cursor_Zeile];
               if nextpath = '..' then begin;
                 chdir('..');
                 shorten_direntry(fs);
                 neu_einlesen(fs);
               end else begin;
                 if fs^.path[length(fs^.path)] <> '\' then
                 fs^.path := fs^.path + '\';
                 fs^.path :=  fs^.path+nextpath;
                 chdir(fs^.path);
                 neu_einlesen(fs);
               end;
             end else begin;
               auswahl_beenden := true;
             end;
           end;
     #72 : begin; { Pfeil hoch }
             if cursor_Zeile > 1 then begin;
               dec(cursor_Zeile);
             end else begin;
               if Start_Anzeige > 0 then dec(Start_Anzeige);
             end;
           end;

     #73 : begin; { Page up }
             if Start_Anzeige > 11+cursor_zeile then begin;
               dec(Start_Anzeige,11);
             end else begin;
               if Start_Anzeige > 11 then begin;
                 dec(Start_Anzeige,11);
                 Cursor_Zeile := Start_Anzeige+0;
               end else begin;
                 Start_Anzeige := 0;
                 Cursor_Zeile := 1;
               end;
             end;
           end;

     #80 : begin; { Pfeil runter }
             if cursor_Zeile < 11 then begin;
               inc(cursor_Zeile);
             end else begin;
               if Start_Anzeige < count-12 then inc(Start_Anzeige);
             end;
           end;

     #81 : begin; { Page down }
             if Start_Anzeige+25 < count then begin;
               inc(Start_Anzeige,11);
             end else begin;
                 Start_Anzeige := count-12;
                 Cursor_Zeile := 11;
             end;
           end;

     #71 : begin;
             Start_Anzeige := 0;
             Cursor_Zeile  := 1;
           end;

     #79 : begin;
             Start_Anzeige := count - 12;
             Cursor_Zeile  := 11;
           end;


     #32 : begin; { Space }
             if fselected^[Start_Anzeige+Cursor_Zeile] then begin;
               fselected^[Start_Anzeige+Cursor_Zeile] := false;
               dec(selectcount);
               dec(bytes_selected,fsize^[Start_Anzeige+Cursor_Zeile]);
              end else begin;
               fselected^[Start_Anzeige+Cursor_Zeile] := true;
               inc(selectcount);
               inc(bytes_selected,fsize^[Start_Anzeige+Cursor_Zeile]);
               getdir(0,fpfad^[Start_Anzeige+Cursor_Zeile]);
             end;
           end;
   end;
   draw_files(fs^.sx,fs^.sy,fs);
 end;

 fs^.nofiles := 0;
 for li := 0 to 511 do begin;
   if fselected^[li] then begin;
     inc(fs^.nofiles);
     fs^.fn[fs^.nofiles] := fpfad^[li]+'\'+fnames^[li];
   end;
 end;

  chdir(savepath);
  dispose(fnames);
  dispose(fsize);
  dispose(fselected);
  dispose(fpfad);
  dispose(fattrib);

  dispose(dnames);
  dispose(dsize);
  dispose(dselected);
  dispose(dattrib);
end;

begin;
end.{$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y+}
unit gus_mod;
{
 ****************************************************************************
 ***                   DATA BECKERs  "PC UNDERGROUND"                     ***
 ***                  ================================                    ***
 ***                                                                      ***
 ***                       Modplayer-Unit GUS_MOD                         ***
 ***                                                                      ***
 *** Die Unit GUS_MOD dient zum Abspielen von MODs ber die Gravis Ultra- ***
 *** sound, der in der Demo-Scene etabliertesten Soundkarte.              ***
 ***                                                                      ***
 *** Diese Unit wurde benutzt, um den (FREEWARE-) Mod-Player TCP V1.0     ***
 *** zu programmieren                                                     ***
 ***                                                                      ***
 *** Autor           : Boris Bertelsons  (InspirE)                        ***
 *** Dateiname       : GUS_MOD.PAS                                        ***
 *** Letzte Žnderung : 28.06.1994                                         ***
 *** Version         : 2.0                                                ***
 *** Compiler        : Turbo Pascal 6.0 und h”her                         ***
 ****************************************************************************
}

interface
function  _gus_modload(name : string) : boolean;
{
 L„d die in NAME bergebene Datei in den Speicher und das GUS-Ram. Die
 Function liefert den Wert TRUE, wenn die MOD-Datei einwandfrei geladen
 werden konnte, sonst den Wert FALSE.
}

procedure _gus_modstarten;
{
 Startet die Ausgebe eines galadenen MODs ber den Timer-Interrupt
}

procedure _gus_mod_beenden;
{
 Beendet die Ausgabe eines MODs
}

procedure _gus_initialisieren;
{
 Initialisiert die GUS
}

function _gus_init_env : boolean;
{
 Initialisiert die GUS, keine Hardware-Detection sondern Prfen der
 Umgebungs-Variablen ULTRASND
}

procedure _gus_set_chanelpos;
{
 Setzt die Position der einzelnen GUS-Kan„le
}

{
 *************************************************************************
 ***               T Y P  -  D e k l a r a t i o n e n                 ***
 *************************************************************************
}
type Song_header = record         { Die Globalen Infos zur MOD-Datei  }
       kennung : string[25];
       SongName : string[30];
       Liedlaenge : byte;
       Arrang : array[0..255] of byte;
       Num_Patts : byte;
       Num_Inst : byte;
     end;

type Modinfo = record
       Stimmen : word;
       Tietel  : string[20];
       Patt_anz : word;
     end;

Type Runinfo = record
        Ausschlag : array[1..8] of byte;
        Zeile,
        Pattnr   : integer;
        Volumes  : array[1..8] of byte;
        speed    : byte;
        bpm      : byte;
     end;

type
 PKanalInfo = ^TKanalInfo;
 TKanalInfo = record
   InstNr     : byte;             { Hardware bezogene Variablen       }
   Mempos     : longint;
   Ende       : longint;
   Loop_Start : longint;
   Loop_Ende  : longint;

   Volume     : integer;          { MOD bezogene Variablen            }
   Frequenz   : word;
   Looping    : byte;
   Ton        : integer;
   Start_Ton  : integer;
   Ziel_Ton   : integer;
   Effekt     : byte;
   Opperand   : byte;

   Effektx,                       { Effekt bezogene Variablen         }
   Effekty      : integer;
   Appegpos     : integer;
   slidespeed   : integer;
   vslide       : integer;
   retrig_count : byte;
   vibpos       : byte;
   vibx         : byte;
   viby         : byte;
 end;

 PInstrumenrInfo = ^TInstrumentInfo;
 TInstrumentInfo = record
   Name       : string[22];
   Mempos     : longint;
   Ende       : longint;
   l_Start    : longint;
   l_ende     : longint;
   Groesse    : word;
   Loop_Start : word;
   Loop_Ende  : word;
   Volume     : word;
   Looping    : byte;
 end;


{
 *************************************************************************
 ***             Gloale Konstanten und Variablen                       ***
 *************************************************************************
}
Const
  Play_Chanel : array[1..14]      { Zum ausmaskieren einzelner Kan„le }
    of byte = (1,1,1,1,1,1,1,     { 1 = GUS-Kanal wird gespielt       }
               1,1,1,1,1,1,1);    { 0 = GUS-Kanal wird nicht gespielt }

var Kanaele       : array[0..31] of PKanalInfo;
    Instrumente   : array[0..31] of PInstrumenrInfo;
  MOD_Stimmen     : word;         { Anzahl der Stimmen (4/8)          }
  MOD_Patternsize : word;         { GrӇe eines MOD-Patterns in Byte  }
  stop_Thevoice   : array[1..8] of boolean;
  vh              : Song_Header;  { Globale Song - Definitionen       }
  Modinfptr       : pointer;
  Modinf          : Modinfo;
  Runinf          : Runinfo;
  chpos           : array[1..8] of integer; { Pos. d. Kanals im Halbkreis}


implementation
uses dos,crt,design,fselect;

const VibratoTable : array[0..63] of integer =(
	0,24,49,74,97,120,141,161,
	180,197,212,224,235,244,250,253,
	255,253,250,244,235,224,212,197,
	180,161,141,120,97,74,49,24,
	0,-24,-49,-74,-97,-120,-141,-161,
	-180,-197,-212,-224,-235,-244,-250,-253,
	-255,-253,-250,-244,-235,-224,-212,-197,
	-180,-161,-141,-120,-97,-74,-49,-24);

const Voice_Divisor : array[14..32] of byte =
       (43,40,37,35,33,31,30,28,27,26,25,24,23,22,21,20,20,19,18);
      Voice_Base : array[14..14] of longint =
       (88195);

const GUS_Environment : boolean = true;
  Modinstanz : byte = 31;         { Anzahl der Instrumente in einer   }
                                  { MOD-Datei (15 oder 31)            }
  ModId : array[1..3] of          { Kennungen fr 4-stimmige MODs     }
        String = ('M.K.','FLT4','4CHN');
  Chn6 : string = '6CHN';         { Kennung fr 6-stimmige MODs       }
  chn8 : string = '8CHN';         { Kennung fr 8-stimmige MODs       }
  ModKennungen : string           { Alle MOD-Kennungen zur Detection  }
    = 'M.K.FLT44CHN6CHN8CHN';
  Interrupt_speed : word = 50;    { Anzahl Aufrufe Interrupts         }
  Num_Voices = 14;                { Wir benutzen 14 GUS - Kan„le ...  }
  U_Ram_Freepos : longint = 2;    { Zur Verwaltung des GUS - RAM      }

  Play_Voice = 0; Stop_Voice = 3; { Konstanten zur Auswahl des Typs   }
  Bit8       = 0; Bit16      = 4; { der zu spielenden Stimme ...      }
  No_Loop    = 0; Mit_Loop   = 8;
  Unidirect  = 0; Bidirect   = 16;
  Go_forw    = 0; Go_Back    = 64;

var GUS_envstr : string;
    GUS_BASE : word;
  oldv : array[0..15] of integer;
  tickcounter,                    { Zur Geschwindigkeits-Steuerung    }
  ticklimit    : word;
  altertimer   : pointer;         { Pointer auf den alten Timer-Int.  }
  i            : Integer ;        { die wohl beliebteste Variable ;)  }
  gusmf        : file;            { Zum Handling der MOD-Datei        }
  Pattern      : array[0..127]    { Pointer auf die Pattern im Ram    }
                 of pointer;


{$L Gusasm}
procedure U_StartVoice(Nr,Modus : byte); external;
{
 Startet den in Nr bergebenen Kanal der Gus im ber Modus eingestellten
 Modus
}

procedure u_Voicefreq(Nr : byte;Freq : word); external;
{
 Setzt die Frequenz Freq fr den in Nr eingestellten Kanal
}

procedure u_VoiceBalance(Nr,balance : byte); external;
{
 Zum Einstellen der Balance des in Nr angegebenen Kanals. Fr balance sind
 Werte von 0 bis 15 erlaubt, wobei 0 fr ganz links, 7 fr mittig und 15
 fr ganz rechts steht
}

procedure u_VoiceVolume(Nr : byte; Vol : word); external;
{
 Hiermit setzen Sie die Lautst„rke Vol des in Nr bergebenen Kanals
}

procedure u_delay; external;
{
 Zum Warten beim Zugriff auf selbst-modifizierende Register des GF1,
 zum internen Gebrauch
}

function  detect_gus : word; external;
{
 Zur Erkennung der GUS. Die Funktion liefert eine 0, wenn eine Karte
 gefunden wurde, und eine 1, wenn keine GUS erkannt wurde. Diese Funktion
 stellt gleichzeitig den richtigen Base-Port fr die GUS ein.
}

procedure u_Initialize; external;
{
 Initialisiert die Gravis Ultrasound.
}

procedure Ultra_Mem2Gus(samp : pointer;start : longint;laenge : word); external;
{
 Mit dieser Procedure kopieren Sie ein Sampel aus dem Ram in das RAM der GUS
 Das ber samp adressierte Sampel wird dabei mittels der Poke-Methode ber-
 tragen. In laenge geben Sie die L„nge des zu bertragenden Sampels an.
}

procedure gus_speaker_on; external;
{
 Schaltet den Lautsprecher der GUS ein.
}

procedure u_Voicedata(start,lsta,sende : longint;Nr : word); external;
{
 Stellt sie Paramterer fr einen Kanal ein. Dabei bezeichnet start die
 Anfangsposition der Stimme im GUS-Ram, lsta den Start der Loop und sende
 die End-Position des Kanals. Die Nummer des Kanals w„hlen Sie ber Nr.
}

function  Ffaktor(t:word) : word; external;
{
 Die Funktion Ffaktor liefert die der Notennummer t entsprechende Frequenz
 fr die GUS aus der Mod-Frequenztabelle
}

function  Notennr(hoehe : word) : byte; external;
{
 Hiermit ermitteln Sie aus dem in hoehe bergebenen Tonh”hen-Wert aus der
 MOD-Datei die Nummer der Note.
}

procedure voice_rampin(Stimme:byte;vol : word); external;
{
 Diese Funktion wird benutzt, um das Knacken von Sampels am Anfang zu ver-
 meiden. Die in Stimme ausgew„hlte Stimme wird nicht sofort auf die in vol
 bergebene Lautst„rke gesetzt, sondern mit der schnellstm”glichen GUS-Ramp
 von 0 auf die Lautst„rke hochgeslidet.
 Die Procedure ist ein Ersatz fr u_VoiceVolume.
}

procedure voice_slidein(nr,speed : byte;vol : word); external;
{
 Mit dieser Procedure k”nnen Sie einen Kanal der GUS einfaden. Nr bezeichnet
 die Nummer des zu fadenden Kanals, in vol bergeben Sie die Ziel-Lautst„rke.
 Bei der Geschwindigkeit geben die oberen beiden Bits die Ramp-Speed und die
 unteren 6 Bits den Increment-Faktor an. Die schnellste Ramp errechen Sie mit
 einem Wert von 63, die langsamste mit 192.
}

procedure dos_getmem(var zeiger:pointer;menge:word); external;
{
 Diese Procedure ist ein Erstatz fr die Pascal Getmem-Procedure. Sie
 benutzt jedoch den DOS-Speicher und ist somit fr TSRs lebensnotwendig,
 um nicht immer einen konstanten Speicherbereich zu belegen, sondern den
 Speicherbedarf an das jeweilige MOD anpassen zu k”nnen.
}

procedure dos_freemem(zeiger:pointer); external;
{
 Dos_Freemem ist das Equivalent zur Pascal Freemem Procedure. Eine GrӇe
 des freizugebenden Speichers ist nicht anzugeben.
}

procedure init_gus_base(base : word); external;
{
 Initialisiert die Gravis Ultrasound mit der in Base bergebenen Adresse.
}


{$L loadin}
procedure loadin; external;    { Ansi - Pic }


procedure init_the_gus(base : word);
begin;
  init_gus_base(base);
end;

procedure u_init;
var li : integer;
begin;
   u_Initialize;                  { Init im Assembler - Teil }
end;

FUNCTION ConvertString(Source : Pointer; Size : BYTE):String;
{
 Zur umwandlung eines ASCIIZ-Strings in einen Pascal-String
}
VAR
   WorkStr : String;
BEGIN
   Move(Source^,WorkStr[1],Size);
   WorkStr[0] := CHR(Size);
   if pos(#0,Workstr) <> 0 then WorkStr[0] := chr(pos(#0,Workstr)-1);
   ConvertString := WorkStr;
END;

procedure Lade_Instrument(Nr : byte);
{
 L„d das Instrument mit der Nummer nr in das GUS-Ram
}
var gr : longint;
    samp : pointer;
begin;
   gr := Instrumente[nr]^.Groesse;
   if gr > 10 then begin;      { Nur laden wenn > 10, sonst eh crap ! }
     dos_getmem(samp,gr);
     Blockread(gusmf,samp^,gr);
     U_Ram_freepos := U_Ram_freepos + (16-(U_Ram_freepos MOD 16));
     Instrumente[nr]^.Mempos := U_Ram_freepos;
     Ultra_Mem2Gus(samp,Instrumente[nr]^.Mempos,gr);
     dos_freemem(samp);           { Stimmen-Variablen initialisieren  }
     Instrumente[nr]^.l_start :=
        Instrumente[nr]^.Mempos + Instrumente[nr]^.Loop_Start;
     if Instrumente[nr]^.Looping = Mit_loop then begin;
       Instrumente[nr]^.ende :=
         Instrumente[nr]^.Mempos + Instrumente[nr]^.Loop_Ende;
     end else begin;
       Instrumente[nr]^.ende := Instrumente[nr]^.Mempos + gr - 25;
     end;
     Inc(U_Ram_Freepos,gr);       { Verwaltungszeiger weiter setzen   }
   end;
end;

procedure Neue_Interrupt_Speed(speed : word);
{
 Stellt die Geschwindigkeit des Interrupts entsprechend den BpM ein.
}
var zaehler : word;
    loz,hiz : byte;
begin;
 interrupt_speed := round(speed / 2.5);
 zaehler := 1193180 DIV interrupt_speed;
 loz := lo(zaehler);
 hiz := hi(zaehler);
 asm
  cli
  mov dx,43h
  mov al,36h
  out dx,al
  mov dx,40h
  mov al,loz
  out dx,al
  mov al,hiz
  out dx,al
  sti
 end;
end;

procedure _gus_set_chanelpos;
{
 Setzt die Position der einzelnen GUS-Kan„le
}
begin;
  u_VoiceBalance(1,chpos[1]);
  u_VoiceBalance(2,chpos[2]);
  u_VoiceBalance(3,chpos[3]);
  u_VoiceBalance(4,chpos[4]);
  u_VoiceBalance(5,chpos[5]);
  u_VoiceBalance(6,chpos[6]);
  u_VoiceBalance(7,chpos[7]);
  u_VoiceBalance(8,chpos[8]);
end;

procedure display_loading(s : string);
{
 Zeigt an, wie weit das Laden der Sampel fortgeschritten ist.
}
var li,slen : integer;
var z : integer;
begin;
  for z := 0 to 12 do begin;
    move(ptr(seg(loadin),ofs(loadin)+z*34*2)^,ptr($B800,z*160+8*160+44)^,34*2);
  end;
  while pos('\',s) <> 0 do begin;
    delete(s,1,pos('\',s));
  end;
  slen := length(s);
  slen := (15 - slen) div 2;
  for li := 1 to slen do s := ' '+s;
  gotoxy(33,13);
  write(s);
end;

function _gus_modload(name : string) : boolean;
{
 L„d die in name bergebene MOD-Datei. Setzt voraus, daá die angegebene
 Datei im Pfad existiert und nicht schreibgeschtzt ist.
}
var dummya : array[0..30] of byte;{ Fr die String - Behandlung       }
    daptr : pointer;              { Pointer auf dummya                }
    dumw : word;                  { Dummy-Variablen zum Einlesen      }
    dumb : byte;
    Restlaenge : longint;         { Zum ermitteln der Patternzahl     }
    li : integer;
    Kennung : array[1..4] of char;{ Die Kennung der MOD-Datei         }
    ias : integer;                { Instrumenten-abh„ngige Startpos.  }
begin;
  U_Ram_freepos := 32;
  for li := 0 to 15 do begin;
    new(Kanaele[li]);
    kanaele[li]^.vibpos := 0;
  end;
  for li := 0 to 31 do begin;
     new(Instrumente[li]);
     Instrumente[li]^.Name := '';
  end;

  runinf.Zeile := 0;
  runinf.Pattnr := -1;
  tickcounter := 0;
  ticklimit := 6;
  runinf.speed := 6;
  runinf.bpm := 125;
  ias := 0;
  daptr := @dummya;

  assign(gusmf,name);             { File ”ffnen + L„nge initialisieren}
  reset(gusmf,1);

  save_screen;
  display_loading(name);

  Restlaenge := filesize(gusmf);
  Restlaenge := Restlaenge  - 1084;

  seek(gusmf,1080);               { Prfen, ob MOD mit 15/31 Stimmen  }
  Blockread(gusmf,Kennung,4);
  if pos(Kennung,Modkennungen) = 0 then begin;
    { 15 Stimmen ? }
    seek(gusmf,600);
    Blockread(gusmf,Kennung,4);
    if pos(Kennung,Modkennungen) = 0 then begin;
      { Keine gltige .MOD-Datei }
      writeln('Keine gltige .MOD - Datei !!!');
      halt(0);
    end else begin;
      Modinstanz := 15;
      ias := -16*30;
    end;
  end;

  if (Kennung = MODId[1]) or      { Stimmenzahl der MOD-Datei ?       }
     (Kennung = MODId[2]) or
     (Kennung = MODId[3])
  then begin;
    MOD_Stimmen := 4;
    MOD_Patternsize := 4*256;
  end else
    if (Kennung = CHn6) then begin;
      _gus_modload := false;
      exit;
    end else
      if (Kennung = CHn8) then begin;
        MOD_Stimmen := 8;
        MOD_Patternsize := 8*256;
      end;

  seek(gusmf,0);
  Blockread(gusmf,dummya,20);     { Namen der Datei ermitteln         }
  vh.SongName := ConvertString(daptr,20);
  seek(gusmf,950+ias);            { Liedl„nge in Pattern              }
  Blockread(gusmf,vh.Liedlaenge,1);
  seek(gusmf,952+ias);            { Arrangement einlesen              }
  Blockread(gusmf,vh.Arrang,128);

  vh.Num_Inst := Modinstanz;      { Instrumente (15/31) einlesen      }
  seek(gusmf,20+ias);

  for li := 1 to 32 do Instrumente[li]^.Name := '';

  for li := 1 to vh.Num_Inst do begin;
    Blockread(gusmf,dummya,22);   { Instrumenten - Name               }
    Instrumente[li]^.Name := ConvertString(daptr,22);

    Blockread(gusmf,dumw,2);      { L„nge des Sampels                 }
    Instrumente[li]^.Groesse := swap(dumw) * 2;

    Blockread(gusmf,dumb,1);      { Lautst„rke einlesen               }
    Blockread(gusmf,dumb,1);
    Instrumente[li]^.Volume := dumb;

    Blockread(gusmf,dumw,2);      { Start der Loop einlesen           }
    Instrumente[li]^.Loop_Start := swap(dumw) * 2;
    Blockread(gusmf,dumw,2);

    dumw := swap(dumw) * 2;       { Loopende aus Start+L„nge einlesen }
    Instrumente[li]^.Loop_Ende := Instrumente[li]^.Loop_Start+dumw;

    if (Instrumente[li]^.Loop_Ende -      { Looping im Instrument ?           }
        Instrumente[li]^.Loop_Start) >= 10 then begin;
      Instrumente[li]^.Looping := mit_loop;
    end else begin;
      Instrumente[li]^.Looping := no_loop;
    end;
    Dec(Restlaenge,Instrumente[li]^.Groesse);
  end;

  Vh.Num_Patts := Restlaenge DIV MOD_Patternsize ; { Patternzahl ?    }
  seek(gusmf,1084+ias);

  for li := 1 to Vh.Num_Patts do begin; { Pattern einlesen            }
    dos_getmem(Pattern[li],MOD_Patternsize );
    Blockread(gusmf,Pattern[li]^,MOD_Patternsize );
  end;

  for li := 1 to vh.Num_Inst do begin; { Instrumente einlesen         }
    Lade_Instrument(li);
    screen[16,23+li].a := 5;
  end;

  close(gusmf);

  for i := 1 to 31 do begin; { Kanal-Variablen initialisieren         }
    u_VoiceBalance (i,7) ;
    u_VoiceVolume (i,0) ;
    u_VoiceFreq (i,12000);
    U_StartVoice(i,Stop_Voice);
    u_Voicedata(0,0,0,i);
  end;
  runinf.Zeile := 0;                     { Laufzeit - Variablen init. }
  runinf.Pattnr := -1;
  tickcounter := 0;
  ticklimit := 6;
  runinf.speed := 6;
  runinf.bpm := 125;
  if MOD_Stimmen = 4 then begin;  { Kan„le im Halbkreis anordnen      }
    chpos[1] := 2;
    chpos[2] := 5;
    chpos[3] := 9;
    chpos[4] := 12;
    _gus_set_chanelpos;;
  end;
  if MOD_Stimmen = 8 then begin;
    chpos[1] := 1;
    chpos[2] := 3;
    chpos[3] := 5;
    chpos[4] := 7;
    chpos[5] := 7;
    chpos[6] := 9;
    chpos[7] := 11;
    chpos[8] := 13;
    _gus_set_chanelpos;;
  end;

  neue_interrupt_Speed(runinf.bpm);
  restore_screen;
  Modinf.Stimmen  := MOD_Stimmen;  { Konstante MOD-Infos in Struktur   }
  Modinf.Tietel   := vh.Songname;  { zur šbergabe                      }
  Modinf.Patt_anz := Vh.Liedlaenge;
  _gus_modload    := true;
end;


procedure effekt_vibrato(nr : byte);
{
 Aus dem Effekt-Handling ausgelagerte Vibrato-Procedure
}
var vibswap : integer;
begin;
  inc(Kanaele[nr]^.vibpos,Kanaele[nr]^.vibx);
  if Kanaele[nr]^.vibpos > 64 then
    dec(Kanaele[nr]^.vibpos,64);
  vibswap :=
    (VibratoTable[Kanaele[nr]^.vibpos] * Kanaele[nr]^.viby) div 256;
  inc(Kanaele[nr]^.Start_Ton,vibswap);
  if Kanaele[nr]^.Start_Ton < 1 then
    Kanaele[nr]^.Start_Ton := 1;
  Kanaele[nr]^.Frequenz :=
    longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
  u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
end;


procedure E_toneportamento(nr : byte);
{
 Aus dem Effekt-Handling ausgelagerte TonePortamento-Procedure
}
begin;
  if Kanaele[nr]^.slidespeed < 0 then
  begin
    inc(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.slidespeed);
    if Kanaele[nr]^.Start_Ton < Kanaele[nr]^.Ziel_Ton then
      Kanaele[nr]^.Start_Ton := Kanaele[nr]^.Ziel_Ton;
  end else begin
    inc(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.slidespeed);
    if Kanaele[nr]^.Start_Ton > Kanaele[nr]^.Ziel_Ton then
      Kanaele[nr]^.Start_Ton := Kanaele[nr]^.Ziel_Ton;
  end;

  if Kanaele[nr]^.Start_Ton < 1 then
    Kanaele[nr]^.Start_Ton := 1;
  Kanaele[nr]^.Frequenz :=
    longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
  u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
  oldv[nr] := Kanaele[nr]^.Start_Ton;
end;

procedure EI_toneportamento(nr : byte);
{
 Init fr die aus dem Effekt-Handling ausgelagerte Vibrato-Procedure
}
begin;
  { Inc-Faktor bestimmen }
  if Kanaele[nr]^.Opperand <> 0 then
  begin;
    if Kanaele[nr]^.Start_Ton > Kanaele[nr]^.Ziel_Ton then
    begin;
      Kanaele[nr]^.slidespeed := -(Kanaele[nr]^.Opperand);
    end else begin;
      Kanaele[nr]^.slidespeed := (Kanaele[nr]^.Opperand);
    end;
  end;
  if Kanaele[nr]^.Start_Ton < 1 then
    Kanaele[nr]^.Start_Ton := 1;
  Kanaele[nr]^.Frequenz :=
    longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
  u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
  oldv[nr] := Kanaele[nr]^.Start_Ton;
end;

procedure Initialisiere_Effekte(nr : byte);
var swaplong      : longint;
    vibswap       : integer;
begin;
  if Kanaele[nr]^.Effekt = 0 then exit;
  case Kanaele[nr]^.Effekt of
    0 : begin; { Appegio }
          Kanaele[nr]^.Appegpos := 0;
          Kanaele[nr]^.Effektx := Kanaele[nr]^.Opperand shr 4;
          Kanaele[nr]^.Effekty := Kanaele[nr]^.Opperand and $0f;

          inc(Kanaele[nr]^.Appegpos);
          case (Kanaele[nr]^.Appegpos MOD 3) of
            0 : begin; {ap = 3 !}
                  Kanaele[nr]^.Start_Ton :=
                  Kanaele[nr]^.Ton + Kanaele[nr]^.Effekty;
                end;
            1 : begin; {ap = 1 !}
                  Kanaele[nr]^.Start_Ton :=
                  Kanaele[nr]^.Ton;
                end;
            2 : begin; {ap = 2 !}
                  Kanaele[nr]^.Start_Ton :=
                  Kanaele[nr]^.Ton + Kanaele[nr]^.Effektx;
                end;
          end;
          if Kanaele[nr]^.Start_Ton < 1 then
            Kanaele[nr]^.Start_Ton := 1;
          Kanaele[nr]^.Frequenz :=
            longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
          u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
        end;
    1 : begin;  { Portamento up }
          dec(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.Opperand);
          if Kanaele[nr]^.Start_Ton < 1 then
            Kanaele[nr]^.Start_Ton := 1;
          Kanaele[nr]^.Frequenz :=
            longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
          u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
        end;
    2 : begin;  { Portamento down }
          inc(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.Opperand);
          if Kanaele[nr]^.Start_Ton < 1 then
            Kanaele[nr]^.Start_Ton := 1;
          Kanaele[nr]^.Frequenz :=
            longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
          u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
        end;
    3 : begin; { Tone Portamento }
          EI_toneportamento(nr);
        end;
    4 : begin;  { Vibrato  *new* }
          Kanaele[nr]^.vibx := Kanaele[nr]^.Opperand shr 4;
          Kanaele[nr]^.viby := Kanaele[nr]^.Opperand and $0f;
          effekt_vibrato(nr);
        end;
    5 : begin; {NOTE SLIDE + VOLUME SLIDE:   *new* }
          { init }
          if Kanaele[nr]^.Opperand <= $0f then
          begin;
            Kanaele[nr]^.vslide := -(Kanaele[nr]^.Opperand AND $0f);
            Kanaele[nr]^.slidespeed := -(Kanaele[nr]^.Opperand AND $0f);
          end else begin;
            Kanaele[nr]^.vslide := (Kanaele[nr]^.Opperand shr 4);
            Kanaele[nr]^.slidespeed := (Kanaele[nr]^.Opperand shr 4);
          end;
          { volume slide }
          inc(Kanaele[nr]^.volume,Kanaele[nr]^.vslide);
          if Kanaele[nr]^.volume < 0 then Kanaele[nr]^.volume := 0;
          if Kanaele[nr]^.volume > 63 then Kanaele[nr]^.volume := 63;
          u_VoiceVolume(Nr,Kanaele[nr]^.volume);
          { Note slide }
          inc(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.slidespeed);
          if Kanaele[nr]^.Start_Ton < 1 then
            Kanaele[nr]^.Start_Ton := 1;
          Kanaele[nr]^.Frequenz :=
            longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
          u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
        end;
    6 : begin;  { Vibrato & Volume slide  *new* }
          { init }
          Kanaele[nr]^.vibx := Kanaele[nr]^.Opperand shr 4;
          Kanaele[nr]^.viby := Kanaele[nr]^.Opperand and $0f;
          if Kanaele[nr]^.Opperand <= $0f then
          begin;
            Kanaele[nr]^.vslide := -(Kanaele[nr]^.Opperand AND $0f);
          end else begin;
            Kanaele[nr]^.vslide := (Kanaele[nr]^.Opperand shr 4);
          end;
          { volume slide }
          inc(Kanaele[nr]^.volume,Kanaele[nr]^.vslide);
          if Kanaele[nr]^.volume < 0 then Kanaele[nr]^.volume := 0;
          if Kanaele[nr]^.volume > 63 then Kanaele[nr]^.volume := 63;
          u_VoiceVolume(Nr,Kanaele[nr]^.volume);
          { vibrato }
          effekt_vibrato(nr);
        end;
    7 : begin; { tremolo  *new* }
           Kanaele[nr]^.vibx := Kanaele[nr]^.Opperand shr 4;
           Kanaele[nr]^.viby := Kanaele[nr]^.Opperand and $0f;
           inc(Kanaele[nr]^.vibpos,Kanaele[nr]^.vibx);
           if Kanaele[nr]^.vibpos > 64 then
             dec(Kanaele[nr]^.vibpos);
           vibswap :=
             (VibratoTable[Kanaele[nr]^.vibpos] * Kanaele[nr]^.viby) div 256;
           inc(Kanaele[nr]^.Volume,vibswap);
           if Kanaele[nr]^.Volume < 0 then Kanaele[nr]^.Volume := 0;
           if Kanaele[nr]^.Volume > 63 then Kanaele[nr]^.Volume := 63;
           u_VoiceVolume(nr,Kanaele[nr]^.volume);
        end;
    8 : begin; { not used !!! }
          {
           Wird offiziell nicht verwendet. Daher gut geeignet, um bestimmte
           Events in einem Demo zu syncronisieren ...
          }
        end;
    9 : begin;  { Sampel - Offset *new* }
          swaplong := longint((Kanaele[nr]^.Opperand+1)) * 256;
          Kanaele[nr]^.Mempos := Kanaele[nr]^.Mempos+swaplong;
          u_Voicedata(Kanaele[nr]^.Mempos,Kanaele[nr]^.Loop_Start,
                    Kanaele[nr]^.Ende,nr);
          U_StartVoice(nr,Play_Voice+Bit8+Kanaele[nr]^.Looping+Unidirect);
        end;
   $a : begin;  { Volume sliding  *new* }
          if Kanaele[nr]^.Opperand <= $0f then
          begin;
            Kanaele[nr]^.vslide := -(Kanaele[nr]^.Opperand AND $0f);
          end else begin;
            Kanaele[nr]^.vslide := (Kanaele[nr]^.Opperand shr 4);
          end;
          inc(Kanaele[nr]^.volume,Kanaele[nr]^.vslide);
          if Kanaele[nr]^.volume < 0 then Kanaele[nr]^.volume := 0;
          if Kanaele[nr]^.volume > 63 then Kanaele[nr]^.volume := 63;
          u_VoiceVolume(Nr,Kanaele[nr]^.volume);
        end;
   $b : begin; { Position Jump *ok* }
          runinf.Zeile := 64;
          runinf.Pattnr := Kanaele[nr]^.Opperand;
        end;
   $c : begin; { Set Note Volume *ok* }
          if Kanaele[nr]^.Opperand > 63 then Kanaele[nr]^.Opperand := 63;
          if Kanaele[nr]^.Opperand < 1 then
          begin
            Kanaele[nr]^.volume := 0;
            u_VoiceVolume(nr,0);
            U_StartVoice(nr,Stop_Voice);
            stop_Thevoice[nr] := true;
          end else begin
            Kanaele[nr]^.volume := Kanaele[nr]^.Opperand;
            u_VoiceVolume(Nr,Kanaele[nr]^.volume);
            Runinf.Volumes[nr] := 63;
          end;
        end;
   $d : begin; { Patterm Break *ok* }
          runinf.Zeile := 64;
        end;
   $e : begin;  { Erweiterter Effekt - Befehl }
          case (Kanaele[nr]^.Opperand shr 4) of
            1 : begin; { Fine slide up }
                  dec(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.Opperand and $0f);
                  if Kanaele[nr]^.Start_Ton < 1 then Kanaele[nr]^.Start_Ton := 1;
                  Kanaele[nr]^.Frequenz :=
                    longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
                  u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
                end;
            2 : begin; { Fine slide down }
                  inc(Kanaele[nr]^.Start_Ton,Kanaele[nr]^.Opperand and $0f);
                  if Kanaele[nr]^.Start_Ton < 1 then Kanaele[nr]^.Start_Ton := 1;
                  Kanaele[nr]^.Frequenz :=
                    longint(Voice_Base[14] div Kanaele[nr]^.Start_Ton);
                  u_VoiceFreq(nr,Kanaele[nr]^.Frequenz);
                end;
            9 : begin; { Retriggering !!! *new* }
                  Kanaele[nr]^.Retrig_count :=
                    Kanaele[nr]^.Opperand and $0f;
                end;
           $a : begin; { fine volume slide up }
                  Kanaele[nr]^.vslide := (Kanaele[nr]^.Opperand AND $0f);
                  inc(Kanaele[nr]^.volume,Kanaele[nr]^.vslide);
                  if Kanaele[nr]^.volume < 0 then Kanaele[nr]^.volume := 0;
                  if Kanaele[nr]^.volume > 63 then Kanaele[nr]^.volume := 63;
                  u_VoiceVolume(Nr,Kanaele[nr]^.volume);
                end;
           $b : begin; { fine volume slide down }
                  Kanaele[nr]^.vslide := (Kanaele[nr]^.Opperand AND $0f);
                  dec(Kanaele[nr]^.volume,Kanaele[nr]^.vslide);
                  if Kanaele[nr]^.volume < 0 then Kanaele[nr]^.volume := 0;
                  if Kanaele[nr]^.volume > 63 then Kanaele[nr]^.volume := 63;
                  u_VoiceVolume(Nr,Kanaele[nr]^.volume);
                end;
           $c : begin;  { Cut Voice *ok* }
                  stop_Thevoice[nr] := true;
                end;
           end;
        end;
   $f : begin; { Set Speed  *ok* }
          if Kanaele[nr]^.Opperand <= $f then begin;
            ticklimit := Kanaele[nr]^.Opperand;
            runinf.speed := ticklimit;
          end else begin;
            runinf.bpm := Kanaele[nr]^.Opperand;
            neue_interrupt_Speed(Kanaele[nr]^.Opperand);
          end;
        end;
  end;
end;

procedure play_pattern_gus;
{
 Diese Procedure wird periodisch aufgerufen. Sie spielt eine Zeile der
 MOD-Datei ab.
}
var li        : integer;
    dumw      : word;
    Die_Zeile : array[1..8,0..3] of Byte;
    Effekt    : byte;
    Ton       : word;
    Inst      : byte;
begin;
{
 **************************************************************************
 ***   Im Mod vorrcken                                                 ***
 **************************************************************************
}
  inc(runinf.Zeile);              { Eine Zeile vorrcken              }
  if runinf.Zeile > 64 then runinf.Zeile := 1;
  if runinf.Zeile = 1 then begin; { Neues Pattern ?                   }
    inc(runinf.Pattnr);
    if runinf.Pattnr > vh.Liedlaenge then runinf.Pattnr := 1;
  end;
                                  { Noten laden                       }
  move(ptr(seg(pattern[vh.Arrang[runinf.Pattnr]+1]^),
       ofs(pattern[vh.Arrang[runinf.Pattnr]+1]^)+
          (runinf.Zeile-1)*4*Mod_Stimmen)^,
       Die_Zeile,4*8);

{
 **************************************************************************
 ***   Die Stimmen abarbeiten                                           ***
 **************************************************************************
}
  for li := 1 to MOD_Stimmen do begin;
    if play_chanel[li] = 1 then begin;
      stop_Thevoice[li] := false;

      Ton  := ((Die_Zeile[li,0] AND $0f) shl 8)+Die_Zeile[li,1];
      Inst := (Die_Zeile[li,0] AND $f0)+((Die_Zeile[li,2] AND $F0) SHR 4);
      Kanaele[li]^.Effekt   := Die_Zeile[li,2] AND $0f;
      Kanaele[li]^.Opperand := Die_Zeile[li,3];

      Kanaele[li]^.Start_Ton := oldv[li];

      if Ton <> 0 then begin;  { Ist ein Ton eingetragen ??? }
        if Kanaele[li]^.Effekt = 3 then begin;
          Kanaele[li]^.Ziel_Ton := Ton;
        end else begin;
          Kanaele[li]^.Ton := Ton;
          Kanaele[li]^.Start_Ton := Ton;
          oldv[li] := Kanaele[li]^.Start_Ton;
        end;
      end;

      If Inst <> 0 then begin; { neues Instrument benutzen ??? }
        Kanaele[li]^.InstNr     := Inst;
        Kanaele[li]^.Mempos     := Instrumente[Kanaele[li]^.InstNr]^.Mempos;
        Kanaele[li]^.Loop_Start := Instrumente[Kanaele[li]^.InstNr]^.l_start;
        Kanaele[li]^.Ende       := Instrumente[Kanaele[li]^.InstNr]^.ende;
        Kanaele[li]^.volume     := Instrumente[Kanaele[li]^.InstNr]^.volume;
        Kanaele[li]^.Looping    := Instrumente[Kanaele[li]^.InstNr]^.Looping;
        u_Voicedata(Kanaele[li]^.Mempos,Kanaele[li]^.Loop_Start,
                    Kanaele[li]^.Ende,li);
      end;
      Kanaele[li]^.Retrig_count := 0;

      Initialisiere_Effekte(li);


      If (Ton <> 0) then begin; { Note angeschlagen }
        Kanaele[li]^.Frequenz := longint(Voice_Base[14] div Kanaele[li]^.Start_Ton);
        u_VoiceFreq(li,Kanaele[li]^.Frequenz); { Frequenz setzen }


        if Kanaele[li]^.Effekt = $c then begin; { Extra, weil sonst zu frh ! }
          if Kanaele[li]^.Opperand > 63 then Kanaele[li]^.Opperand := 63;
          if Kanaele[li]^.Opperand < 1 then
          begin
            Kanaele[li]^.volume := 0;
            u_VoiceVolume(li,0);
            U_StartVoice(li,Stop_Voice);
            stop_Thevoice[li] := true;
          end else begin
            Kanaele[li]^.volume := Kanaele[li]^.Opperand;
            u_VoiceVolume(li,Kanaele[li]^.volume);
            Runinf.Volumes[li] := 63;
          end;
        end else begin;
          if Kanaele[li]^.volume > 63 then Kanaele[li]^.volume := 63;
           voice_rampin(li,Kanaele[li]^.volume);
           Runinf.Volumes[li] := 63;
        end;

        U_StartVoice(li,Stop_Voice); { Alte Stimme anhalten }

        u_Voicedata(Kanaele[li]^.Mempos,Kanaele[li]^.Loop_Start,
                    Kanaele[li]^.Ende,li);
        if not stop_Thevoice[li] then begin; { Neue Stimme starten }
          U_StartVoice(li,Play_Voice+Bit8+Kanaele[li]^.Looping+Unidirect);
          Runinf.Ausschlag[li] := Kanaele[li]^.volume * 4; { Fr Equilizer }
        end;
      end; { Note angeschlagen }
    end else begin;
      u_VoiceVolume(li,0);
    end;
  end; {for}
end;

procedure tick_effects;
var li : integer;
    vibswap : integer;
begin;
  for li := 1 to MOD_Stimmen do begin;
    if runinf.volumes[li] > 0 then
      dec(runinf.volumes[li]);
    case Kanaele[li]^.Effekt of { Laufzeit - Effekte abarbeiten         }
      0 : begin;
            inc(Kanaele[li]^.Appegpos);
            case (Kanaele[li]^.Appegpos MOD 3) of
              0 : begin; {ap = 3 !}
                    Kanaele[li]^.Start_Ton :=
                    Kanaele[li]^.Ton + Kanaele[li]^.Effekty;
                  end;
              1 : begin; {ap = 1 !}
                    Kanaele[li]^.Start_Ton :=
                    Kanaele[li]^.Ton;
                  end;
              2 : begin; {ap = 2 !}
                    Kanaele[li]^.Start_Ton :=
                    Kanaele[li]^.Ton + Kanaele[li]^.Effektx;
                  end;
             end;
          end;
      1 : begin;
          {!"! new }
            Kanaele[li]^.Opperand := Kanaele[li]^.Opperand and $0F;
          {!"! new end }
            dec(Kanaele[li]^.Start_Ton,Kanaele[li]^.Opperand);
            if Kanaele[li]^.Start_Ton < 1 then
              Kanaele[li]^.Start_Ton := 1;
            Kanaele[li]^.Frequenz :=
              longint(Voice_Base[14] div Kanaele[li]^.Start_Ton);
            u_VoiceFreq(li,Kanaele[li]^.Frequenz);
          end;
      2 : begin;
          {!"! new }
            Kanaele[li]^.Opperand := Kanaele[li]^.Opperand and $0F;
          {!"! new end }
            inc(Kanaele[li]^.Start_Ton,Kanaele[li]^.Opperand);
            if Kanaele[li]^.Start_Ton < 1 then
              Kanaele[li]^.Start_Ton := 1;
            Kanaele[li]^.Frequenz :=
              longint(Voice_Base[14] div Kanaele[li]^.Start_Ton);
            u_VoiceFreq(li,Kanaele[li]^.Frequenz);
          end;
      3 : begin; { Tone Portamento }
            E_toneportamento(li);
          end;
      4 : begin;  { vibrato  *new* }
            effekt_vibrato(li);
          end;
     5 : begin;
           { volume slide }
           inc(Kanaele[li]^.volume,Kanaele[li]^.vslide);
           if Kanaele[li]^.volume < 0 then Kanaele[li]^.volume := 0;
           if Kanaele[li]^.volume > 63 then Kanaele[li]^.volume := 63;
           u_VoiceVolume(li,Kanaele[li]^.volume);
           { Note slide }
           inc(Kanaele[li]^.Start_Ton,Kanaele[li]^.slidespeed);
            if Kanaele[li]^.Start_Ton < 1 then
              Kanaele[li]^.Start_Ton := 1;
           Kanaele[li]^.Frequenz :=
             longint(Voice_Base[14] div Kanaele[li]^.Start_Ton);
           u_VoiceFreq(li,Kanaele[li]^.Frequenz);
         end;
     6 : begin;
           { volume slide }
           inc(Kanaele[li]^.volume,Kanaele[li]^.vslide);
           if Kanaele[li]^.volume < 0 then Kanaele[li]^.volume := 0;
           if Kanaele[li]^.volume > 63 then Kanaele[li]^.volume := 63;
           u_VoiceVolume(li,Kanaele[li]^.volume);
           { vibrato }
           inc(Kanaele[li]^.vibpos,Kanaele[li]^.vibx);
           if Kanaele[li]^.vibpos > 64 then
             dec(Kanaele[li]^.vibpos);
           vibswap :=
             (VibratoTable[Kanaele[li]^.vibpos] * Kanaele[li]^.viby) div 256;
           inc(Kanaele[li]^.Start_Ton,vibswap);
            if Kanaele[li]^.Start_Ton < 1 then
              Kanaele[li]^.Start_Ton := 1;
           Kanaele[li]^.Frequenz :=
             longint(Voice_Base[14] div Kanaele[li]^.Start_Ton);
           u_VoiceFreq(li,Kanaele[li]^.Frequenz);
         end;
     7 : begin; { tremolo  *new* }
            inc(Kanaele[li]^.vibpos,Kanaele[li]^.vibx);
            if Kanaele[li]^.vibpos > 64 then
              dec(Kanaele[li]^.vibpos);
            vibswap :=
              (VibratoTable[Kanaele[li]^.vibpos] * Kanaele[li]^.viby) div 256;
            inc(Kanaele[li]^.Volume,vibswap);
            if Kanaele[li]^.Volume < 0 then Kanaele[li]^.Volume := 0;
            if Kanaele[li]^.Volume > 63 then Kanaele[li]^.Volume := 63;
            u_VoiceVolume(li,Kanaele[li]^.volume);
         end;
    8 : begin; { not used !!! }
        end;
    $a : begin; { Volume sliding   **new* }
           inc(Kanaele[li]^.volume,Kanaele[li]^.vslide);
           if Kanaele[li]^.volume < 0 then Kanaele[li]^.volume := 0;
           if Kanaele[li]^.volume > 63 then Kanaele[li]^.volume := 63;
           u_VoiceVolume(li,Kanaele[li]^.volume);
         end;
    $e : begin;  { Erweiterter Effekt - Befehl }
          case (Kanaele[li]^.Opperand shr 4) of
              9: begin; { Retriggering !!! }
                   if Kanaele[li]^.Opperand and $0f <> 0 then begin;
                     dec(Kanaele[li]^.Retrig_count);
                     if Kanaele[li]^.Retrig_count = 0 then begin;
                       Kanaele[li]^.Retrig_count := Kanaele[li]^.Opperand and $0f;
                       u_Voicedata(Kanaele[li]^.Mempos,Kanaele[li]^.Loop_Start,
                              Kanaele[li]^.Ende,li);
                       U_StartVoice(li,Play_Voice+Bit8+Kanaele[li]^.Looping+Unidirect);
                     end;
                   end;
                 end;
           end;
        end;
    end;
  end;
end;

{$F+}
procedure mytimer; interrupt;
{
 Mein Timer-Interrupt
}
begin;
  tick_effects;
  inc(tickcounter);
  if tickcounter >= ticklimit then begin;
    Tickcounter := 0;
    Play_Pattern_gus;
  end;
  Port[$20] := $20;
end;

procedure tue_nichts; interrupt;
{
 Dummy-Interrupt. Auf ihn wird geschaltet, wenn die Ausgabe angehalten wird.
}
begin;
  port[$20] := $20;
end;

procedure _gus_modstarten;
{
 Startet die Ausgabe des MOD-Files ber den Timer-Interrupt. Das MOD-File
 muá bereits geladen worden sein !
}
var zaehler : word;
    loz,hiz : byte;
begin;
 zaehler := 1193180 DIV interrupt_speed;
 loz := lo(zaehler);
 hiz := hi(zaehler);
 asm
  cli
  mov dx,43h
  mov al,36h
  out dx,al
  mov dx,40h
  mov al,loz
  out dx,al
  mov al,hiz
  out dx,al
 end;
 getintvec(8,altertimer);
 setintvec(8,@Mytimer);
 asm sti end;
end;


procedure _gus_player_pause;
{
 H„lt die Ausgabe ber den Timer-Interrupt an
}
var li : integer;
begin;
 setintvec(8,@Tue_nichts);
 for li := 0 to 31 do
   u_VoiceVolume (li,0) ;
end;

procedure _gus_player_continue;
{
 Setzt die Ausgabe ber den Timer-Interrupt fort.
}
var li : integer;
begin;
 setintvec(8,@Mytimer);
 for li := 1 to 31 do
   Voice_Rampin(li,Kanaele[li]^.volume);
end;

procedure timerint_zurueck;
{
 Resettet den Timer-Interrupt auf seinen ursprnglichen Wert.
}
begin;
 asm
  cli
  mov dx,43h
  mov al,36h
  out dx,al
  xor ax,ax
  mov dx,40h
  out dx,al
  out dx,al
 end;
 setintvec(8,altertimer);
 asm sti end;
end;

procedure dispose_mod;
{
 Entfernt ein geladenens MOD aus dem Hauptspeicher. Die Sampels auf der GUS
 werden NICHT gel”scht.
}
begin;
  for i := 0 to 31 do begin;
    U_StartVoice(i,Stop_Voice);
  end;
  for i := 1 to Vh.Num_Patts do begin;
    dos_freemem(Pattern[i]);
  end;
  for i := 0 to 15 do begin;
    dispose(Kanaele[i]);
  end;
  for i := 0 to 31 do begin;
     dispose(Instrumente[i]);
  end;
end;

procedure _gus_mod_beenden;
{
 Beendet die Ausgabe eines MODs
}
begin;
  timerint_zurueck;
  dispose_mod;
end;

procedure _gus_initialisieren;
{
 Initialisiert die GUS
}
begin;
  u_init;
  gus_speaker_on;
end;

procedure get_from_environment;
{
 Ermittelt die Base-Adresse der GUS aus der Environment-Variablen
 ULTRASND
}
var apos,ipos,dpos : integer;
    astr,istr,dstr,gusstr : string;
    code : integer;
begin;
  GUS_envstr := GetEnv('ULTRASND');

 { GUS - Base erkennen }
  gusstr := Copy(GUS_envstr,1,3);
  val(gusstr,GUS_BASE,code);
  if code <> 0 then begin;
    GUS_Environment := false;
  end else
    GUS_Environment := true;
end;

function dec_2_hex(w : word) : word;
{
 Convertiert eine Dezimal-Zahl in eine Hex-Zahl. Wichtig fr Environment-
 Behandlung
}
const exp : array[1..4] of word = (4096,256,16,0);
var c,hs : string;
    v,i,li : integer;
begin;
  str(w,hs);
  while length(hs) < 4 do hs := '0'+hs;
  w := 0;
  for li := 1 to 4 do begin;
    c := hs[li];
    val(c,v,i);
    w := w + v * exp[li];
  end;
  dec_2_hex := w;
end;

procedure write_environment;
{
 Gibt die aus den Environment ermittelte BASE-Adresse der GUS aus
}
begin;
  if GUS_Environment then begin;
    writeln('þ GUS_BASE: ',GUS_BASE);
    writeln('þ initializing Gravis Ultrasound Card');
    gus_base := dec_2_hex(gus_base);
    init_the_gus(Gus_base);
    delay(777);
  end else begin;
    writeln('The environment-variable ULTRASND is not set !');
    delay(777);
  end;
end;

function _gus_init_env : boolean;
{
 Initialisiert die GUS, keine Hardware-Detection sondern Prfen der
 Umgebungs-Variablen ULTRASND
}
begin;
  clrscr;
  get_from_environment;
  write_environment;
  _gus_init_env := gus_environment;
end;

begin;
end.
{$A+,B-,D+,E+,F+,G+,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 16384,0,250000}

program gusdemo;

uses crt,dos,design,fselect, gus_mod;

type
  Pphun = ^TPhun;
  TPhun = array[0..799] of string[80];

const mod_pfad = 'd:\mods';

const Programm_beenden : boolean = false;

var phun : Pphun;
    phuncount : integer;
    modify_voice : integer;
    i : integer;
    Die_files : Pfileselect_struct;
    curr_modnr : integer;

{
  Einbindung der Ansi - Screens
}

{$L tcpans}
procedure tcpans; external;
{$L we_are}
procedure we_are; external;
{$L buy_it}
procedure buy_it; external;
{$L call}
procedure call; external;
{$L helptxt}
procedure helptxt; external;


function datei_exists(dname : string) : boolean;
{
 Prft, ob die bergebene Datei vorhanden ist
}
var dumf : file;
begin;
  {$I-}
  assign(dumf,dname);
  reset(dumf,1);
  {$I+}
  if IOResult <> 0 then
    datei_exists := false
  else begin;
    datei_exists := true;
    close(dumf);
  end;
end;

procedure color_writeln(s : string);
{
 Zur Ausgabe eines Strings in der TC-Farbkombination
}
var colpos,li : integer;
begin;
  colpos := 1;
  for li := 1 to length(s) do begin;
    if s[li] = ' ' then colpos := 0;
    inc(colpos);
    case colpos of
        1..2 : begin;
                 textcolor(8);
               end;
        3..4 : begin;
                textcolor(2);
               end;
      5..$ff : begin;
                 textcolor(10);
               end;
    end;
    write(s[li]);
  end;
end;

procedure write_dateinamen(s : string);
{
 Gibt zentriert den Dateinamen des Liedes aus
}
var li,slen : integer;
begin;
  gotoxy(33,13);
  while pos('\',s) <> 0 do begin;
    delete(s,1,pos('\',s));
  end;
  slen := length(s);
  slen := (15 - slen) div 2;
  for li := 1 to slen do s := ' '+s;
  write(s);
end;

procedure write_phunliners;
{
 Liest aus der Datei "Phun.txt" drei Zeilen aus und gibt diese auf dem
 Bildschirm aus. Bei der Datei "Phun.txt" handelt es sich um eine frei
 editierbare Text-Datei, die Sie nach Ihrem Belieben ver„ndern k”nnen !
}
var tf : text;
begin;
  randomize;
  if not datei_exists('phun.txt') then exit;
  assign(tf,'phun.txt');
  reset(tf);
  phuncount := 0;
  {$I+}
  if ioresult = 0 then begin;
    while not eof(tf) do begin;
      readln(tf,phun^[phuncount]);
      inc(phuncount);
    end;
    close(tf);
    gotoxy(3,43);
    color_writeln(phun^[random(phuncount)]);
    gotoxy(3,44);
    color_writeln(phun^[random(phuncount)]);
    gotoxy(3,45);
    color_writeln(phun^[random(phuncount)]);
  end;
  {$I-}
end;

procedure display_modinfos;
{
 Gibt die Instrument-Namen des aktuellen Modules aus
}
var li : integer;
begin;
  textcolor(14);
  textbackground(black);
  for li := 1 to 16 do begin;
    gotoxy(6,17+li);
    color_writeln(Instrumente[li]^.name);
    gotoxy(50,17+li);
    color_writeln(Instrumente[li+16]^.name);
  end;
end;

procedure exit_program;
{
 Vorm verlassen des Programms noch schnell 'nen Hinweis auf das TC WHQ,
 die Farpoint Station (04202 76145), anzeigen ...
}
begin;
  display_ansi(@call,co80+font8x8);
  cursor_off;
  repeat until keypressed;
  while keypressed do readkey;
  cursor_on;
  asm mov ax,03; int 10h; end;
  halt;
end;

procedure naechstes_mod;
{
 Startet die Ausgabe des n„chsten selektierten MODs
}
begin;
  _gus_mod_beenden;
  inc(curr_modnr);
  if curr_modnr > Die_Files^.nofiles then
    curr_modnr := 1;
  if not _gus_modload(Die_Files^.fn[curr_modnr]) then begin;
    clrscr;
    gotoxy(10,10);
    write('Sorry dude, Cant''t handle this MOD-File');
    delay(1200);
    exit_program;
  end;
  display_ansi(@tcpans,co80+font8x8);
  cursor_off;
  write_phunliners;
  write_dateinamen(Die_Files^.fn[curr_modnr]);
  display_modinfos;
  fillchar(Play_Chanel,14,1);
  _gus_modstarten;
end;

procedure display_we_are;
{
 Gibt ein ANSI mit Infos ber die Gruppe THE COEXISTENCE aus
}
begin;
  display_ansi(@we_are,co80+font8x8);
  cursor_off;
  repeat until keypressed;
  while keypressed do readkey;
  display_ansi(@tcpans,co80+font8x8);
  cursor_off;
  write_phunliners;
  write_dateinamen(Die_Files^.fn[curr_modnr]);
  display_modinfos;
end;

procedure display_buy_it;
{
 Gibt Werbung fr das Buch PC Underground aus
}
begin;
  display_ansi(@buy_it,co80+font8x8);
  cursor_off;
  repeat until keypressed;
  while keypressed do readkey;
  display_ansi(@tcpans,co80+font8x8);
  cursor_off;
  write_phunliners;
  write_dateinamen(Die_Files^.fn[curr_modnr]);
  display_modinfos;
end;

procedure handle_keys(key1,key2 : char);
{
 reagiert auf die Tastatur-Eingaben des Benutzers
}
var pchan : byte;
begin;
  case key1 of
    #00 : begin;
            case key2 of
              #45 : begin;
                      Programm_beenden := true;
                    end;
              #72 : begin;
                      if modify_voice > 1 then
                        dec(modify_voice);
                    end;
              #80 : begin;
                      if modify_voice < Modinf.Stimmen then
                        inc(modify_voice);
                    end;
              #75 : begin; { cursor left  }
                      runinf.Zeile := 64;
                      dec(runinf.Pattnr,2);
                      if runinf.Pattnr < -1 then runinf.Pattnr := -1;
                    end;
              #77 : begin; { cursor right  }
                      runinf.Zeile := 64;
                      inc(runinf.Pattnr);
                    end;
            end;
          end;
    #27 : begin;
            Programm_beenden := true;
          end;
    #32,
    'W',
    'w',
    'I',
    'i' : begin;
            display_we_are;
          end;
    'D',
    'd',
    'b',
    'B' : begin;
            display_buy_it;
          end;
    'L',
    'l' : begin;
            chpos[modify_voice] := 1;
            _gus_set_chanelpos;
          end;
    'R',
    'r' : begin;
            chpos[modify_voice] := 15;
            _gus_set_chanelpos;
          end;
    'M',
    'm' : begin;
            chpos[modify_voice] := 7;
            _gus_set_chanelpos;
          end;
    'U',
    'u' : begin;
            if Modinf.Stimmen = 4 then
            begin
              chpos[1] := 2;
              chpos[2] := 5;
              chpos[3] := 9;
              chpos[4] := 12;
            end;
            if Modinf.Stimmen = 8 then
            begin
              chpos[1] := 1;
              chpos[2] := 3;
              chpos[3] := 5;
              chpos[4] := 7;
              chpos[5] := 7;
              chpos[6] := 9;
              chpos[7] := 11;
              chpos[8] := 13;
            end;
            _gus_set_chanelpos;
          end;
    ',' : begin; { nach liiiinks }
            if chpos[modify_voice] > 1 then
              dec(chpos[modify_voice]);
            _gus_set_chanelpos;
          end;
    '.' : begin; { nach reeeechts }
            if chpos[modify_voice] < 15 then
              inc(chpos[modify_voice]);
            _gus_set_chanelpos;
          end;
    '1'..
    '8' : begin;
            pchan := ord(key1)-48;
            if Play_Chanel[pchan] = 1 then begin;
              Play_Chanel[pchan] := 0;
              textcolor(10);   gotoxy(77,2+pchan);
              write('M');      textcolor(2);
              write('UTE');
            end else begin;
              Play_Chanel[pchan] := 1;
              textcolor(10);   gotoxy(77,2+pchan);
              write('C');      textcolor(2);
              write('H  ');
            end;
          end;
    'n',
    'N' : begin;
            naechstes_mod;
          end;
  end;
end;

procedure screen_update;
const colvals : array[1..35] of byte =
   (08,08,08,08,08,02,02,02,02,10,10,10,10,10,10,10,10,
    10,10,10,10,10,10,10,10,10,10,10,10,10,05,05,05,05,05);
var volstr : string[66];
    li : integer;
    auss : integer;
begin;
  { Volume-Bars aktualisieren }
  for li := 1 to Modinf.Stimmen do begin;
    for auss := 1 to round(Runinf.Volumes[li] / 1.78) do begin;
      screen[li+2,37+auss].a := colvals[auss];
    end;
    for auss := round(Runinf.Volumes[li] / 1.78)  to 36 do begin;
      screen[li+2,38+auss].a := 7;
    end;
  end;

  { Farblich richtigen Hintergrund fr den Pfeil setzen }
  for li := 1 to 8 do begin;
    if li = modify_voice then begin;
      screen[2+li,34].a := 05;
      screen[2+li,35].a := 05;
      screen[2+li,36].a := 05;
      screen[2+li,37].a := 05;
    end else begin;
      screen[2+li,34].a := 07;
      screen[2+li,35].a := 07;
      screen[2+li,36].a := 07;
      screen[2+li,37].a := 07;
    end;
  end;

  { Laufzeit - Informationen des MODs ausgeben }
  gotoxy(18,14);
  color_writeln(Modinf.Tietel);

  textcolor(7);
  gotoxy(18,16);
  write(runinf.pattnr:3);

  gotoxy(64,16);
  write(runinf.zeile:3);

  gotoxy(64,15);
  write(64:3);

  gotoxy(18,15);
  write(modinf.Patt_anz:3);

  gotoxy(60,14);
  write(runinf.speed,' / ',runinf.bpm);
end;

procedure user;
{
 Prft auf Tastatur-Eingaben und updatet den Screen
}
var ch1,ch2 : char;
begin;
  repeat
    ch1 := #255;
    ch2 := #255;
    if keypressed then begin;
      ch1 := readkey;
      if keypressed then ch2 := readkey;
      handle_keys(ch1,ch2);
    end;
   screen_update;
  until Programm_beenden;
end;


procedure display_help;
{
 Git das Hilfe-Ans aus. Wird auch angezeigt, wenn keine GUS gefunden wurde
}
begin;
  display_ansi(@helptxt,co80+font8x8);
  cursor_off;
  repeat until keypressed;
  while keypressed do readkey;
  exit_program;
end;


function check_commandline : boolean;
{
 returns true, if a module-name was given
}
var pst : string;
    ist_mod : boolean;
    li : integer;
    retval : boolean;
begin;
  retval := false;
  for li := 1 to 9 do begin;
    pst := paramstr(li);
    ist_mod := true;

    if (pos('-h',pst) <> 0) or (pos('-H',pst) <> 0) or
       (pos('-?',pst) <> 0) then
    begin;
      ist_mod := false;
      display_help;
    end;

    if (pst <> '') and ist_mod then begin;
      if pos('.',pst) = 0 then pst := pst + '.mod';
      if datei_exists(pst) then  { glt. mod }
      begin
        inc(Die_Files^.nofiles);
        Die_Files^.fn[Die_Files^.nofiles] := pst;
        retval := true;
      end;
    end;
  end;
  check_commandline := retval;
end;

begin;
  cursor_off;
  clrscr;
  if not _gus_init_env then display_help;

  new(Die_Files);
  new(phun);
  Die_Files^.path := mod_pfad;
  Die_Files^.Mask := '*.mod';
  Die_Files^.sx   := 24;
  Die_Files^.sy   := 10;
  Die_Files^.nofiles := 0;

  Die_Files^.Tietel := 'MOD Datei w„hlen !!!';
  modify_voice := 1;

  for i := 1 to 30 do
    Die_Files^.fn[i] := '---';
  save_screen;
  if not check_commandline then begin;
    select_packdateien(Die_Files);
    repeat
      restore_screen;

      if Die_Files^.fn[1] = '---' then exit_program;

        _gus_initialisieren;

      display_ansi(@tcpans,co80+font8x8);
      cursor_off;
      write_phunliners;

      curr_modnr := 1;
      if not _gus_modload(Die_Files^.fn[1]) then begin;
        clrscr;
        gotoxy(10,10);
        write('Sorry dude, Cant''t handle this MOD-File');
        delay(1200);
        exit_program;
      end;
      write_dateinamen(Die_Files^.fn[1]);
      display_modinfos;
      fillchar(Play_Chanel,14,1);
      _gus_modstarten;

      user;
      _gus_mod_beenden;
      dispose(Die_Files);
      new(Die_Files);
      Die_Files^.path := Mod_pfad;
      Die_Files^.Mask := '*.mod';
      Die_Files^.sx   := 24;
      Die_Files^.sy   := 10;
      Die_Files^.nofiles := 0;
      for i := 1 to 30 do
        Die_Files^.fn[i] := '---';
      Programm_beenden := false;
      select_packdateien(Die_Files);
    until Die_Files^.fn[1] = '---';

      dispose(Die_Files);
    dispose(phun);
    exit_program;
  end else begin;
  restore_screen;

  if Die_Files^.fn[1] = '---' then exit_program;

  _gus_initialisieren;

  display_ansi(@tcpans,co80+font8x8);
  cursor_off;
  write_phunliners;

  curr_modnr := 1;
  _gus_modload(Die_Files^.fn[1]);
  write_dateinamen(Die_Files^.fn[1]);
  display_modinfos;
  fillchar(Play_Chanel,14,1);
  _gus_modstarten;

  user;

  _gus_mod_beenden;
  dispose(Die_Files);
  dispose(phun);
  exit_program;

  end;
end..386
.MODEL TPascal
  b equ byte ptr
  w equ word ptr
  d equ dword ptr


.DATA

extrn aktuelle_stimme     : word;
extrn calc_size           : word;
extrn Mixed_data          : dword;
extrn Mixed_posi          : word;
extrn Mixed_data_st       : dword;

extrn Mixingprocs         : dword;
extrn Leerstimme          : dword;

extrn Laenge_Stimme       : dword
extrn Position_Stimme     : dword
extrn Loop_Laenge_Stimme  : dword
extrn Loop_Start_Stimme   : dword
extrn Segment_Stimme      : dword
extrn Notvol_Stimme       : dword
extrn Incval_Stimme       : dword


.CODE


public stimme_normal
stimme_normal proc pascal ;aktuelle_stimme : word;
 pusha
 mov si,aktuelle_stimme
 dec si
 shl si,2                    ; fr dword-Zugriffw

 mov cx,calc_size

@Lade_loop:

;{ Ist die Stimme am Ende angekommen ? }
  mov bx,w Laenge_Stimme[si]
  sub bx,20
  cmp bx,word ptr Position_Stimme[si+2]
  ja  @Stimme_nicht_am_Ende

;{ Stimme am Ende, Ist sie geloopt ? }
  cmp Loop_Laenge_Stimme[si],10
  jae @Stimme_ist_geloopt

;{Stimme ist am Ende und nicht geloopt => raus}
  mov eax,leerstimme
  mov Mixingprocs[si],eax
  mov Notvol_Stimme[si],0
  jmp @ende_stimme_normal

; {Parameter fr Stimme1 auf Anfang der Loop }
@Stimme_ist_geloopt:
  mov bx,w Loop_Start_Stimme[si]
  mov word ptr Position_Stimme[si + 2],bx

; {Byte aus Sampel der Stimme1 laden }
@Stimme_nicht_am_Ende:
  mov bx,w Segment_Stimme[si]
  mov es,bx
  mov bx,word ptr Position_Stimme[si + 2]
  mov al,es:[bx]
  sub al,128
  mul b Notvol_Stimme[si]
  shr ax,6

@Stimme_ausgeben:
  les di,mixed_data
  add di,mixed_posi
  add es:[di],ax
  add mixed_posi,2

; {Zeiger weitersetzen}
  mov ebx,Incval_Stimme[si]
  add dword ptr Position_Stimme[si],ebx

  loop @Lade_loop

@ende_stimme_normal:
  popa
  ret
stimme_normal endp



public stimme_normal_st
stimme_normal_st proc pascal ;aktuelle_stimme : word;
 pusha
 mov si,aktuelle_stimme
 dec si
 shl si,2                    ; fr dword-Zugriffw

 mov cx,calc_size

@Lade_loop_st:

;{ Ist die Stimme am Ende angekommen ? }
  mov bx,w Laenge_Stimme[si]
  sub bx,20
  cmp bx,word ptr Position_Stimme[si+2]
  ja  @Stimme_nicht_am_Ende_st

;{ Stimme am Ende, Ist sie geloopt ? }
  cmp Loop_Laenge_Stimme[si],10
  jae @Stimme_ist_geloopt_st

;{Stimme ist am Ende und nicht geloopt => raus}
  mov eax,leerstimme
  mov Mixingprocs[si],eax
  mov ax,127
  mov Notvol_Stimme[si],0
  jmp @ende_stimme_normal_st

; {Parameter fr Stimme1 auf Anfang der Loop }
@Stimme_ist_geloopt_st:
  mov bx,w Loop_Start_Stimme[si]
  mov word ptr Position_Stimme[si + 2],bx

; {Byte aus Sampel der Stimme1 laden }
@Stimme_nicht_am_Ende_st:
  mov bx,w Segment_Stimme[si]
  mov es,bx
  mov bx,word ptr Position_Stimme[si + 2]
  mov al,es:[bx]
  sub al,128
  mul b Notvol_Stimme[si]
  shr ax,6

@Stimme_ausgeben_st:
  les di,mixed_data_st
  add di,mixed_posi
  add es:[di],ax
  add mixed_posi,2

; {Zeiger weitersetzen}
  mov ebx,Incval_Stimme[si]
  add dword ptr Position_Stimme[si],ebx

  loop @Lade_loop_st

@ende_stimme_normal_st:
  popa
  ret
stimme_normal_st endp






public Leere_Stimme
Leere_Stimme proc pascal
  ret
Leere_Stimme endp

END
unit design;

interface
uses crt,windos;

procedure writexy(x,y : integer;s : string);
procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
function wrhexb(b : byte) : string;
function wrhexw(w : word) : string;
procedure save_screen;
procedure restore_screen;
Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
procedure cursor_On;
procedure cursor_Off;

implementation

var filenames : array[1..512] of string[12];
const      Screen_Akt   : byte = 1;

procedure writexy(x,y : integer;s : string);
begin;
 gotoxy(x,y);
 write(s);
end;

procedure save_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt <= 4 then begin;
    inc(Screen_Akt);
    move(screen[1],screen[Screen_Akt],8000);
  end;
end;

procedure restore_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt >= 2 then begin;
    move(screen[Screen_Akt],screen[1],8000);
    dec(Screen_Akt);
  end;
end;

procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
const frames : array[1..2,1..6] of char =
 (('Ú','¿','Ù','À','Ä','³'),
  ('É','»','¼','È','Í','º'));
var lx,ly : integer;
    s : string;
begin;
  { obere Zeile }
  s := frames[rt,1];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,2];
  gotoxy(startx,starty);
  write(s);
  { mittleren Zeilen }
  for ly := 1 to dy-2 do begin;
    s := frames[rt,6];
    for lx := 1 to dx-2 do s := s + ' ';
    s := s + frames[rt,6];
    gotoxy(startx,starty+ly);
    write(s);
  end;
  { untere Zeile }
  s := frames[rt,4];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,3];
  gotoxy(startx,starty+dy-1);
  write(s);
end;

Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
var tlaeng : byte;
    deltx,tstartpos : byte;
begin;
  tlaeng := length(s);
  tstartpos := x + ((dx-Tlaeng) SHR 1);
  textcolor(rcol);
  textbackground(bcol);
  rahmen(1,x,y,dx,dy);
  writexy(tstartpos,y,s);
end;

procedure sort_filenames(start,ende : integer);
{
 Hier sollte fr gr”áere Verzeichnise Quick-Sort eingebaut werden !
}
var hilfe : string;
    l1,l2 : integer;
begin;
  for l1 := start to ende-1 do begin;
    for l2 := start to ende-1 do begin;
      if filenames[l2] > filenames[l2+1] then begin;
        hilfe := filenames[l2];
        filenames[l2] := filenames[l2+1];
        filenames[l2+1] := hilfe;
      end;
    end;
  end;
end;

function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
const  zeile : byte = 1;
  spalte : byte = 0;
  Start_fndisp : word = 0;
var
  DirInfo: TSearchRec;
  count : integer;
  Nullpos : byte;
var li,lj : integer;
    inp : char;
    retval : string;
    kasten_gefunden : boolean;
    select : byte;
    changed : boolean;
    End_fndisp : word;
begin
  {$I+}
  for li := 1 to 512 do filenames[li] := ' - - -';
  count := 1;
  FindFirst(mask, faArchive, DirInfo);
  while DosError = 0 do
  begin
    filenames[count] := (DirInfo.Name);
    Nullpos := pos(#0,filenames[count]);
    if Nullpos <> 0 then
      filenames[count] := copy(filenames[count],0,Nullpos-1);
    inc(count);
    FindNext(DirInfo);
  end;
  {$I-}

  sort_filenames(1,count-1);
  save_screen;
  Fenster(5,4,72,16,comment,black,7);
  textcolor(1);
  writexy(21,5,'         Bitte Datei ausw„hlen');
  textcolor(black);
  inp := #255;
  changed := true;
  repeat
    textcolor(black);
    if changed then begin;
      changed := false;
      for lj := 0 to 4 do begin;
        for li := 1 to 12 do begin;
          writexy(7+lj*14,5+li,'            ');
          writexy(7+lj*14,5+li,filenames[lj*12+li+Start_fndisp]);
        end;
      end;
      textcolor(14);
      writexy(7+Spalte*14,5+Zeile,filenames[Spalte*12+Zeile+Start_fndisp]);
    end;
    if keypressed then inp := readkey;
    if ord(inp) = 0 then inp := readkey;
    case ord(inp) of
      32,
      13: begin;
            inp := #13;
            changed := true;
            if (pos('- - -',filenames[Spalte*12+Zeile+Start_fndisp]) = 0) then
              retval := filenames[Spalte*12+Zeile+Start_fndisp]
            else
              retval := 'xxxx';
          end;
      27: begin;
            inp := #27;
            changed := true;
            retval := 'xxxx';
          end;
      71: begin; { Pos 1 }
            inp := #255;
            Zeile  := 1;
            Spalte := 0;
            changed := true;
          end;
      72: begin; { Pfeil up }
            inp := #255;
            changed := true;
            if not ((Zeile = 1) and (Spalte = 0)) then
              dec(Zeile);
            if Zeile = 0 then begin;
              dec(Spalte);
              Zeile := 12;
            end;
          end;
      73: begin; { Page UP }
            if Start_fndisp >= 12 then
              dec(Start_fndisp,12)
            else begin;
              Start_fndisp := 0;
              Zeile := 1;
            end;
            inp := #255;
            changed := true;
          end;
      81: begin; { Page Down }
            if ((Spalte+1)*12+Start_fndisp < count) and
            (Start_fndisp < 500) then
              inc(Start_fndisp,12)
            else
              Start_fndisp := count-11;
            inp := #255;
            changed := true;
          end;
      75: begin; { Pfeil links }
            inp := #255;
            changed := true;
            if Spalte = 0 then begin;
              if Start_fndisp >= 12 then dec(Start_fndisp,12);
            end else begin;
              if Spalte > 0 then dec(Spalte);
            end;
          end;
      77: begin; { Pfeil rechts }
            inp := #255;
            changed := true;
            if Spalte = 4 then begin;
              if ((Spalte+1)*12+Start_fndisp < count) and
              (Start_fndisp < 500) then inc(Start_fndisp,12);
            end else begin;
            if (Spalte < 4) and
              (Zeile+(Spalte+1)*12+Start_fndisp < count) then
                inc(Spalte);
            end;
          end;
      79: begin; { End }
            inp := #255;
            changed := true;
            Spalte := (count-Start_fndisp-12) div 12;
            Zeile := (count-Start_fndisp) - Spalte*12 -1;
          end;
      80: begin; { Pfeil down }
            inp := #255;
            changed := true;
            if ((Zeile = 12) and (Spalte = 4)) then begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then begin;
                inc(Start_fndisp,1);
              end;
            end else begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then
                inc(Zeile);
             end;
            if Zeile > 12 then begin;
              inc(Spalte);
              Zeile := 1;
            end;
          end;
      82 : begin;
            changed := true;
             save_screen;
             textcolor(black);
             rahmen(2,16,9,45,5);
             writexy(20,10,' Dateinamen eingeben ('+mtext+')');
             writexy(20,12,'Name: ');
             readln(retval);
             if retval = '' then retval := 'xxxx';
             restore_screen;
           end;
     end;
  until (inp = #13) or (inp = #27) or (inp = #32)
     or (inp = #82);
  restore_screen;
  textbackground(black);
  textcolor(7);
  select_datei := retval;
end;

function wrhexb(b : byte) : string;
const hexcar : array[0..15] of char =
 ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
begin;
  wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
end;

function wrhexw(w : word) : string;
begin;
  wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
end;

procedure cursor_Off; assembler;
asm
  xor ax,ax
  mov ah,01h
  mov cx,2020h
  int 10h
end;

procedure cursor_on; assembler;
asm
 mov ah,01h
 mov cx,0607h
 int 10h
end;



begin;
end.{

 ****************************************************************************
 ***                   DATA BECKERs  "PC UNDERGROUND"                     ***
 ***                  ================================                    ***
 ***                                                                      ***
 ***                      Beispielprogramm MOD386                         ***
 ***                                                                      ***
 *** Das Programm demonstriert den Einsatz der Unit MOD_SB. Sie k”nnen    ***
 *** 4- und 8-Stimmige MOD-Dateien abspielen. Durch Drcken der Taste     ***
 *** "p" w„hrend des Abspielens k”nnen Sie sich die verbleibende          ***
 *** Processor-Performance ansehen. Sie wird ermittelt, indem die Zeit,   ***
 *** die vor einem Retrace zur Verfgung steht, gemessen wird.            ***
 ***                                                                      ***
 *** Autor           : Boris Bertelsons  (InspirE)                        ***
 *** Dateiname       : MOD386.PAS                                         ***
 *** Letzte Žnderung : 04.04.1994                                         ***
 *** Version         : 2.0                                                ***
 *** Compiler        : Turbo Pascal 6.0 und h”her                         ***
 ****************************************************************************

}



uses crt,dos,mod_sb,variab,design;

{ $define polling}
{
 Normalerweise erfolgt die Ausgabe ber den Timer-Interrupt. Wenn Sie jedoch
 mit dem horizontalen Retrace syncronisieren mssen, dann mssen Sie die
 Polling-Methode benutzen, die den Sound nicht periodisch berechnet, sondern
 dann, wenn Zeit ist. Diesse Methode ist leider etwas langsamer und fhrt
 zu klanglichen Verlusten. Desweiteren kann Sie zu Problemen mit 8-Stimmigen
 MODs fhren. Sie sollte also nur eingesetzt werden, wenn es sich nicht
 "vermeiden" l„át.
}

type
  t = record                      { Fr direkte Screen-Ausgabe        }
       c : char;
       a : byte;
     end;

const Nummods : byte = 0;
      repeatmode : boolean = false;

var gi : integer;
    my_modname : string;
    stapo,stinc : integer;
    ch,dch : char;
    next_song : integer;
    effects : array[1..4] of effect_type;
    Modd : array[1..10] of string;

procedure Scala_Kasten;
var li : integer;
begin;
  textcolor(1);
  textbackground(black);
  clrscr;
  write(' MOD386  Version 2.0, (c) 1994 DATA BECKER',
	      '    Coding: Boris Bertelsons (InspirE)');
  textcolor(lightblue);
  for li := 1 to 10 do begin;
    gotoxy(2,li+4);
    write(li:2,'. ',instnamen[li]);
    gotoxy(28,li+4);
    write(li+10:2,'. ',instnamen[li+10]);
    gotoxy(54,li+4);
    write(li+20:2,'. ',instnamen[li+20]);
  end;
  if Stimmen = 4 then begin;
  textcolor(black);
  textbackground(7);
  writexy(02,16,'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'+
	              'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
  writexy(02,17,'º                        º                    '+
	              '                               º');
  writexy(02,18,'º                        º                    '+
	              '                               º');
  writexy(02,19,'º                        º                    '+
              	'                               º');
  writexy(02,20,'º                        º                    '+
	              '                               º');
  writexy(02,21,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'+
	              'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
  gotoxy(1,23);
  end else begin;
  textcolor(black);
  textbackground(7);
  writexy(02,16,'ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍËÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'+
	              'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
  writexy(02,17,'º                        º                    '+
	              '                               º');
  writexy(02,18,'º                        º                    '+
	              '                               º');
  writexy(02,19,'º                        º                    '+
	              '                               º');
  writexy(02,20,'º                        º                    '+
	              '                               º');
  writexy(02,21,'º                        º                    '+
	              '                               º');
  writexy(02,22,'º                        º                    '+
 	              '                               º');
  writexy(02,23,'º                        º                    '+
	              '                               º');
  writexy(02,24,'º                        º                    '+
	              '                               º');
  writexy(02,25,'ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÊÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ'+
	              'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
  gotoxy(1,23);
  end;
  textbackground(black);
  textcolor(lightblue);
  writexy(47,2,'Volume: ');
  textcolor(lightcyan);
  write(Mastervolume:2);
  textcolor(lightblue);
  textbackground(black);
  writexy(58,2,'Balance ');
  textcolor(14);
  writexy(66,2,'þþþþþþþþþþþþþ');
  textcolor(4);
  writexy(78-Balance DIV 2,2,'þ');
  textcolor(lightblue);
  textbackground(black);
  writexy(36,2,'Filter');
  textcolor(lightcyan);
  write(' OFF');
end;

procedure Scala;
var li,lj : integer;
    screen : array[1..50,1..80] of t absolute $B800:$0000;
    secu : string[3];
begin;
  textcolor(lightblue);
  textbackground(black);
  str(Laufsec,secu);
  if laufsec < 10 then secu := '0'+secu;
  gotoxy(2,3);
  write('Songname : ');
  textcolor(lightcyan);
  write(Songname);
  gotoxy(34,3);
  textcolor(lightblue);
  write('Frequenz : ');
  textcolor(lightcyan);
  write(Sampling_Frequenz:5);
  textcolor(lightblue);
  write(' KHz   Laufzeit : ');
  textcolor(lightcyan);
  write(Laufmin:2,':',secu);
  gotoxy(2,4);
  textcolor(lightblue);
  write('Pattern No.:');
  textcolor(lightcyan);
  write(Lied[mlj]:3);
  textcolor(lightblue);
  write('    Pattern :');
  textcolor(lightcyan);
  write(mlj:3,'/',Liedlaenge:3);
  textcolor(lightblue);
  write('    Zeile :');
  textcolor(lightcyan);
  write(mli:3);
  textcolor(lightblue);
  write('    Geschwindigkeit : ');
  textcolor(lightcyan);
  write(Playspeed:3,'/128');
  gotoxy(2,2);
  textcolor(lightblue);
  write('Memory Free : ');
  textcolor(lightcyan);
  write(Maxavail:6,' KB');
  textcolor(black);
  textbackground(7);
  for li := 1 to Stimmen do
    if In_St[li] <> 0 then writexy(4,16+li,Instnamen[In_St[li]]);

  for lj := 1 to Stimmen do begin;
    for li := 1 to 16 do begin;
      if (Noten_Anschlag[lj] div 10) > li then
        begin;
          screen[16 +lj,29+li].c := 'þ';
          screen[16 +lj,29+li].a := 114;
        end else begin;
          screen[16 +lj,29+li].c := 'þ';
          screen[16 +lj,29+li].a := 112;
        end;
    end;
    for li := 16  to 32 do begin;
      if (Noten_Anschlag[lj] div 10) > li then
        begin;
          screen[16 +lj,29+li].c := 'þ';
          screen[16 +lj,29+li].a := 126;
        end else begin;
          screen[16 +lj,29+li].c := 'þ';
          screen[16 +lj,29+li].a := 112;
        end;
    end;
    for li := 33 to 48 do begin;
      if (Noten_Anschlag[lj] div 10) > li then
        begin;
          screen[16 +lj,29+li].c := 'þ';
          screen[16 +lj,29+li].a := 116;
        end else begin;
          screen[16 +lj,29+li].c := 'þ';
          screen[16 +lj,29+li].a := 112;
        end;
    end;
  end;
end;

var retraceincs : word;
    systemspeed : longint;
    modspeed    : longint;

procedure test_waitretrace;
begin;
retraceincs := 0;
  asm
    MOV   DX,03dAh
@WD_R:
    inc word ptr retraceincs
    IN    AL,DX
    TEST  AL,8d
    JZ    @WD_R
@WD_D:
    inc word ptr retraceincs
    IN    AL,DX
    TEST  AL,8d
    JNZ   @WD_D
  end;
end;

procedure test_systemspeed;
var li : integer;
begin;
  writeln;
  writeln('Testing System-Speed, please wait ...');
  writeln;
  test_waitretrace;
  systemspeed := 0;
  for li := 1 to 70 do begin;
    test_waitretrace;
    systemspeed := systemspeed+retraceincs;
  end;
end;

procedure test_modspeed;
var li : integer;
begin;
  writeln;
  writeln('Testing MOD-Speed, please wait ...');
  writeln;
  test_waitretrace;
  modspeed := 0;
  for li := 1 to 210 do begin;
    test_waitretrace;
    modspeed := modspeed+retraceincs;
  end;
  modspeed := modspeed div 3;
end;

procedure write_performance;
begin;
  writeln;
  writeln('Remain :',(modspeed*100/systemspeed):6:2,' % Processor performance');
  writeln;
  writeln;
  writeln;
  write('Press Enter to continue ...');
  readln;
end;

procedure Play_the_Mod(s : string);
var h : byte;
    error : integer;
    li : integer;
begin;
{ if not SB16Detected then} Reset_Sb16;
 mod_SetSpeed(66);
 mod_Samplefreq(Samfreq);
 dsp_rdy_sb16 := true;
 error := lade_moddatei(s,AUTO,AUTO,Samfreq);
 if error <> 0 then begin;
   clrscr;
   writeln('Fehler beim Laden der MOD-Datei ! ');
   if error = -1 then writeln('Datei nicht gefunden !');
   if error = -2 then writeln('Nicht gengend Speicher verfgbar !');
   halt(0);
 end;
 {$ifdef polling}
   start_polling;
 {$else}
   periodisch_on;   { Schaltet das periodische Abspielen ein }
 {$endif}

 Scala_Kasten;
 ch := #255;
 while not (ch=#27) and not (upcase(ch)='X')
   and not (upcase(ch)='N') do begin;
  {$ifdef polling}
    mod_waitretrace(15);
  {$endif}
  Scala;
  if keypressed then ch := readkey;
  case ch of
    #0  : begin;
            dch := readkey;
            case dch of
              #61 : begin; { F3 }
                       if Mastervolume > 0 then dec(Mastervolume);
                       Set_Volume(Mastervolume);
                       textbackground(black);
                       textcolor(lightblue);
                       writexy(47,2,'Volume: ');
                       textcolor(lightcyan);
                       write(Mastervolume:2);
                       ch := #255;
                     end;
              #62 : begin; { F4 }
                       if Mastervolume < 31 then inc(Mastervolume);
                       Set_Volume(Mastervolume);
                       textbackground(black);
                       textcolor(lightblue);
                       writexy(47,2,'Volume: ');
                       textcolor(lightcyan);
                       write(Mastervolume:2);
                       ch := #255;
                     end;
              #63 : begin; { F5 }
                       if Balance > 0 then dec(Balance);
                       Set_Balance(Balance);
                       textcolor(lightblue);
                       textbackground(black);
                       writexy(58,2,'Balance ');
                       textcolor(14);
                       writexy(66,2,'þþþþþþþþþþþþþ');
                       textcolor(4);
                       writexy(78-Balance DIV 2,2,'þ');
                       ch := #255;
                     end;
              #64 : begin; { F6 }
                       if Balance < 24 then inc(Balance);
                       Set_Balance(Balance);
                       textcolor(lightblue);
                       textbackground(black);
                       writexy(58,2,'Balance ');
                       textcolor(14);
                       writexy(66,2,'þþþþþþþþþþþþþ');
                       textcolor(4);
                       writexy(78-Balance DIV 2,2,'þ');
                       ch := #255;
                     end;
              else begin;
                     ch := #255;
                   end;
             end;
          end;
    '6' : begin;
            inc(mli);
            ch := #255;
          end;
    'P',
    'p' : begin;
            textcolor(7);
            textbackground(black);
            clrscr;
            test_modspeed;
            write_performance;
            Scala_Kasten;
            ch := #255;
          end;
    'f' : begin;
            filter_activ := not filter_activ;
            if filter_activ then begin;
						  filter_ein;
              textcolor(lightblue);
              textbackground(black);
              writexy(36,2,'Filter');
              textcolor(lightcyan);
              write(' ON ');
            end else begin;
						  filter_mid;
              textcolor(lightblue);
              textbackground(black);
              writexy(36,2,'Filter');
              textcolor(lightcyan);
              write(' OFF');
            end;
            ch := #255;
          end;
    '4' : begin;
            if mli > 0 then
              dec(mli)
            else begin;
              if mlj > 0 then begin;
                dec(mlj);
                mli := 63
              end else begin;
                mli := 0;
                mlj := 0;
              end;
            end;
            ch := #255;
           end;
    '3' : begin;
            mli := 0;
            inc(mlj);
            ch := #255;
          end;
    '1' : begin;
            if mlj > 0 then begin;
              dec(mlj);
              mli := 0;
            end;
            ch := #255;
           end;
    'N',
    'n' : begin;
            next_song := 1;
          end;
    'x' : begin;
            next_song := 255;
          end;
    #27 : begin;
            next_song := 255;
          end;
    else begin;
           ch := #255;
    end;
   end;
 end;
 outfading := true;
 while outvolume > 1 do begin;
   Scala;
 end;
 {$ifndef polling}
   periodisch_off;
 {$endif}
 ende_mod;
{ if not SB16Detected then} Reset_Sb16;
end;

procedure Write_Helptext;
begin;
  textcolor(lightgray);
  textbackground(black);
  clrscr;
  writeln(' MOD386  Version 2.0, (c) 1994 DATA BECKER',
	      '    Coding: Boris Bertelsons (InspirE)');
  writeln;
  writeln(' Usage: Mod386 <Filename[.MOD]> [optionen]');
  writeln;
  writeln(' Optionen sind:');
	writeln(' -H        : Dieser Screen');
  writeln(' -In       : Benutze den Interrupt n');
	writeln(' -Dn       : Benutze den DMA-Kanal n');
  writeln(' -Pxxx     : Benutze die Baseadresse xxx');
  writeln(' -Snn      : W„hle Sampelrate in KHz. Zul„ssig: ',
	        '8,10,13,16,22');
  writeln(' -r        : Schaltet den Repeat-Select Modus ein');
	writeln(' -sb       : Keine Erkennung einer SB16');
  writeln(' <name>    : zus„tzliche .MOD-Datei, spielt in zuf„lliger',
	        ' Reihenfolge');
  writeln;
  writeln;
  writeln('                    - Taste fr mehr -');
  writeln;
  repeat until keypressed; readkey;
  clrscr;
  writeln(' MOD386  Version 2.0, (c) 1994 DATA BECKER',
	      '    Coding: Boris Bertelsons (InspirE)');
  writeln;
  writeln(' Tastaturbelegung w„hrend des Abspielens ');
  writeln;
  writeln('  F : Schaltet den X-Bass Filter Ein/Aus');
  writeln(' F3 : Lautst„rke leiser      F4 : Lautst„rke lauter ');
  writeln(' F5 : Balance nach links     F6 : Balance nach rechts');
  writeln('  1 : Ein Pattern zurck       3 : Ein Pattern vor');
  writeln('  4 : Eine Zeile zurck        6 : Eine Zeile vor');
  writeln('  n : N„chste Datei        esc,X : Beenden');
  writeln('  p : Remaining System Performance');
  writeln;
  Cursor_On;
  halt(0);
end;

procedure interprete_commandline;
var cs,hs : string;
    li,code : integer;
    sampelfr : word;
    Datnm : boolean;
begin;
  for li := 1 to 10 do begin;
    cs := paramstr(li);
    Datnm := true;
    { Hilfe Angefordert ? }
    if (pos('-h',cs) <> 0) or (pos('/h',cs) <> 0) or
       (pos('-H',cs) <> 0) or (pos('/H',cs) <> 0) or
       (pos('-?',cs) <> 0) or (pos('/?',cs) <> 0) then begin;
       write_Helptext;
      Datnm := false;
    end;
    { Repeatmode ? }
    if (pos('-r',cs) <> 0) or (pos('/r',cs) <> 0) or
       (pos('-R',cs) <> 0) or (pos('/R',cs) <> 0) then begin;
       Repeatmode := true;
      Datnm := false;
    end;
    { Force NO Sb16 ? }
    if (pos('-sb',cs) <> 0) or (pos('/sb',cs) <> 0) or
       (pos('-SB',cs) <> 0) or (pos('/SB',cs) <> 0) then begin;
       force_SB := true;
      Datnm := false;
    end;
    if (pos('-i',cs) <> 0) or (pos('/i',cs) <> 0) or
       (pos('-I',cs) <> 0) or (pos('/I',cs) <> 0) then begin;
      force_irq := true;
      hs := copy(cs,3,length(cs)-2);
      val(hs,dsp_irq,code);
      Datnm := false;
    end;
    { Force DMA ? }
    if (pos('-d',cs) <> 0) or (pos('/d',cs) <> 0) or
       (pos('-D',cs) <> 0) or (pos('/D',cs) <> 0) then begin;
      force_dma := true;
      hs := copy(cs,3,length(cs)-2);
      val(hs,dma_ch,code);
      Datnm := false;
    end;
    { Force Base ? }
    if (pos('-p',cs) <> 0) or (pos('/p',cs) <> 0) or
       (pos('-P',cs) <> 0) or (pos('/P',cs) <> 0) then begin;
       hs := copy(cs,3,length(cs)-2);
       if hs = '200' then dsp_adr := $200;
       if hs = '210' then dsp_adr := $210;
       if hs = '220' then dsp_adr := $220;
       if hs = '230' then dsp_adr := $230;
       if hs = '240' then dsp_adr := $240;
       if hs = '250' then dsp_adr := $250;
       if hs = '260' then dsp_adr := $260;
       if hs = '270' then dsp_adr := $270;
       if hs = '280' then dsp_adr := $280;
       Startport := dsp_adr;
       Endport   := dsp_adr;
      Datnm := false;
    end;
    { Setze Sampelrate ? }
    if (pos('-s',cs) <> 0) or (pos('/s',cs) <> 0) or
       (pos('-S',cs) <> 0) or (pos('/S',cs) <> 0) then begin;
      hs := copy(cs,3,length(cs)-2);
      val(hs,Sampelfr,code);
      if Sampelfr >= 8000 then Sampelfr := Sampelfr DIV 1000;
      if Sampelfr >= 8 then Samfreq := 8;
      if Sampelfr >= 10 then Samfreq := 10;
      if Sampelfr >= 13 then Samfreq := 13;
      if Sampelfr >= 16 then Samfreq := 16;
      if Sampelfr >= 22 then Samfreq := 22;
      Datnm := false;
    end;
    if Datnm then begin;
      if cs <> '' then begin;
        Inc(Nummods);
        Modd[Nummods] := cs;
      end;
    end;
  end;
end;

procedure write_vocmessage;
begin;
  clrscr;
  writexy(10,08,'Achtung !  Das VOC wird gnadenlos geloopt !!!');
  writexy(10,10,'Beenden mit der Taste   >>  Q  <<');
  writexy(10,14,'M”glichst den Smartdrv entfernen, weil laaaaaaangsam !');
  writexy(10,21,'                            E N J O Y');
end;

procedure play_sound(datname : string);
var li : integer;
    ch : char;
begin;
  for li := 1 to length(datname) do
     datname[li] := upcase(Datname[li]);
  if pos('.MOD',datname) <> 0 then begin;
    Play_The_Mod(datname);
    exit;
  end;
  if pos('.VOC',datname) <> 0 then begin;
  repeat
    Reset_Sb16;
    write_vocmessage;
    Init_Voc(datname);
    ch := #0;
    repeat
      if keypressed then ch := readkey;
      if ch = 'p' then begin;
        voc_pause;
        repeat
          ch := readkey;
        until ch = 'c';
        voc_continue;
      end;
    until VOC_READY or (ch = 'n') or (upcase(ch) = 'Q');
    VOC_DONE;
  until upcase(ch) = 'Q';
  end;
end;


begin;
 Samfreq := 22;
 clrscr;
 test_systemspeed;
 cursor_off;
 interprete_commandline;
 if (Nummods = 0) and not repeatmode then begin;
   textcolor(15);
   textbackground(1);
   clrscr;
   Nummods := 1;
   modd[1] := ''+select_datei('*.?o?','*.?o?','','Bitte MOD-Datei ausw„hlen');
   if modd[1] = 'xxxx' then begin;
     clrscr;
		 writeln('Als ''nen MOD-Datei máen Sie schon haben !');
     Cursor_on;
     halt(0);
   end;
 end;
 for i := 1 to Nummods do begin;
   if pos('.',modd[i]) = 0 then modd[i] := modd[i]+'.mod';
 end;
 Init_The_Mod;
 stereo := false;
 next_song := random(Nummods)+1;
 textcolor(lightgray);
 textbackground(black);
 write_sbconfig;
 writeln;
 writeln;
 write('                     ENTER  fr  weiter ...');
 readln;
 repeat
   if repeatmode then begin;
     textcolor(15);
     textbackground(1);
     clrscr;
     modd[1] := ''+select_datei('*.?o?','*.?o?','','');
     if modd[1] = 'xxxx' then next_song := 255
     else Play_Sound(modd[1]);
   end else
     Play_Sound(modd[next_song]);
   if next_song <> 255 then next_song := random(Nummods)+1;
 until next_song = 255;
 cursor_on;
 textmode(3);
end.

{

 *****************************************************************************
 ***                   DATA BECKERs  "PC UNDERGROUND"                      ***
 ***                  ================================                     ***
 ***                                                                       ***
 ***                           Unit MOD_SB                                 ***
 ***                                                                       ***
 ***  Die Unit stellt Routinen zum Abspielen von MOD-Dateien ber den      ***
 ***  Soundblaster zur Verfgung. Da die Routinen sehr zeitkritisch sind,  ***
 ***  wurden die entscheidenden Mix-Routinen in 386er Assembler geschrie-  ***
 ***  ben. Darum l„uft die Unit NICHT auf 286er Rechnern.                  ***
 ***  Sie k”nnen die MOD-Dateien entweder ber den Timerinterrupt steuern  ***
 ***  lassen, oder im sog. Polling-Verfahren aufrufen.                     ***
 ***  Die Routinen ben”tigen fr eine 8-Stimmige MOD-Datei auf einem       ***
 ***  486dx-33 bei einer Ausgaberate von 16 KHz weniger als 20% Rechenzeit ***
 ***                                                                       ***
 ***                                                                       ***
 *** Autor           : Boris Bertelsons  (InspirE)                         ***
 *** Dateiname       : MOD_SB.PAS                                          ***
 *** Letzte Žnderung : 04.04.1994                                          ***
 *** Version         : 2.0                                                 ***
 *** Compiler        : Turbo Pascal 6.0 und h”her                          ***
 *****************************************************************************

}

{$F+}
unit mod_sb;

interface uses crt,dos,variab;

 var andycount : word;

 procedure voc_pause;
 procedure voc_continue;
 function Init_Sb : boolean;
 {
  Diese Function initialisiert den Soundblaster. Sie erkennt automa-
  tisch Base-Adress und IRQ, prft, um welche Soundblasterversion es
  sich handelt und setzt entsprechende globale Variablen, die z.B.
  mittels write_sbConfig ausgegeben werden k”nnen. Sie liefert TRUE
  zurck, wenn die Initialisierung erfolgreich war, ansonsten FALSE.
  Der Lautsprecher fr Sampling-Ausgabe wird eingeschaltet. Der
  DMA-Ready Interrupt wird auf eine eigene Routine verbogen.
 }

 procedure dsp_block_sb16(gr,dgr : word;bk : pointer;b1,b2 : boolean);
 {
  Spielt den ber bk adressierten Block via DMA ab
 }

 procedure mod_waitretrace(num : byte);
 {
  Das Warten auf einen Bildschirm-Retrace sollte mit dieser Procedure
  erfolgen, wenn MOD's abgespielt werden (sonst Ruckeln)
 }

 procedure mod_autodetect(what : boolean);
 {
  Setzt die Speed-Erkennung ON/OFF
 }

 procedure mod_SetSpeed(msp : word);
 {
  Setzt die Variable "Speed"
 }

 procedure mod_SetLoop(msl : word);
 {
  Setzt die Variable "Sound_Schleifen"
 }

 procedure mod_SetLoopflag(loopen : boolean);
 {
  Setzt ON/OFF, ob eine zu Ende abgespielte Moddatei wieder von
  Anfang an abgespielt wird
 }

 procedure mod_transpose(transposerwert : integer);
 {
  Setzt den Transposer-Wert. Evtl. fr Soundeffekte zu gebrauchen,
  um einen Ton hoch- oder runterzuziehen. Sonst NICHT ver„ndern.
 }

 procedure mod_Samplefreq(Rate : integer);
 {
  Setzt die Samplefrequenz fr die Ausgabe. Wert*1000 = Frequenz.
  Zul„ssige Werte sind 8,10,16,22
 }

 function lade_moddatei(modname : string;ispeed,iloop : integer;freq : byte) : integer;
 {
  L„d die unter modname angegebene Moddatei. Mittels ispeed und iloop
  k”nnen die Variablen "Speed" und "Sound_Schleifen" vorgegeben
  werden, sinnvoller ist jedoch die Angabe AUTO fr beide Werte
 }

 procedure ende_mod;
 {
  Beendet das Abspielen einer Mod-Datei und entfernt sie aus
  dem Speicher
 }

 procedure periodisch_on;
 {
  Schaltet das Abspielen einer MOD-Datei ein. Muá zum Starten
  aufgerufen werden
 }

 procedure periodisch_off;
 {
  H„lt das Abspielen einer MOD-Datei an. Die MOD-Datei bleibt im
  Speicher und kann ber periodisch_one wieder gestartet werden
 }

 procedure write_sbConfig;
 {
  Gibt die gefundene Konfiguration aus (Textmodus !). Alternativ:
  Direkter Zugriff auf die entsprechenden Variablen.
 }

 procedure calculate_music;
 {
  Berechnet ein Teilstck Musik. Wird Periodisch oder in einer Schleife
  aufgerufen
 }

 procedure Filter_Ein;
 {
  Schaltet den XBass-Filter ein
 }

 procedure Filter_MID;
 {
  Schaltet den Filter auf Normalbetrieb
 }
 procedure Filter_Aus;
 {
  Schaltet den Filter auf H”hen-Hervorhebung
 }

 procedure Set_Balance(Wert : byte);
 {
  Die Procedure Setzt die Balance entsprechend dem bergebenen Wert.
  Dabei steht 0 fr ganz links, 12 fr Mitte und 24 fr ganz rechts
 }

 procedure Set_Volume(Wert : byte);
 {
  Die Procedure setzt die Lautst„rke fr die generelle (!) Ausgabe
  (Master Volume). Erlaubte Werte liegen zwischen 0 und 31
 }

 procedure wr_dsp_sb16(v : byte);
 {
  Schreibt den bergebenen Wert in das Soundblaster-Register
 }

 function init_The_Mod : boolean;
 {
  Initiatisiert die .MOD-Routienen. Resettet den SB und setzt ben”tigte
  Variablen
 }

 FUNCTION Reset_sb16 : BOOLEAN;
 {
  Resettet die SB-Karte. Liefert TURE, wenn erfolgreich
 }

 procedure Set_Timeconst_sb16(tc : byte);
 {
  Setzt die Timer-Konstante die nach der Formel
  tc := 256-(1.000.000 / Frequenz) berechnet wird
 }

 procedure Fade_Musix_out;
 {
  Zieht die Lautst„rke langsam runter. Z.B fr Programmende einsetzten
 }

 procedure Spiele_Sb(Segm,Offs,dgr,dsize : word);
 {
  Spielt den adressierten Block ber DMA ab. Fr SB / SB Pro
 }

 procedure Spiele_Sb16(Segm,Offs,dgr,dsize : word);
 {
  Spielt den adressierten Block ber DMA ab. Fr SB 16
 }

 procedure init_data;
 {
  Initialisiert die Variablen der Unit
 }

 Procedure Init_Voc(filename : string);
 {
  Startet die Ausgabe einer VOC-Datei. Eine parallele Ausgabe von VOC
  und MOD ist NICHT m”glich
 }

 procedure voc_done;
 {
  Beendet das Abspielen einer VOC-Datei.
 }

const bpm : byte = 125;

var SaveExitProc : Pointer;             { N”tig, da eigene Exitproc  }
 mycli : byte;                          { Flag, ob Soundberechnung   }
                                        { aktiv                      }
 music_played : boolean;                { Flag, TRUE wenn Musik ge-  }
                                        { spielt wurde               }
implementation

const
 Speed3 : word = 58;
 Loop3  : word = 42;

Var
 Tonhoehe_Stimme : array[1..8] of word;
 tonhoehe : word;                       { Der Wert der Tonh”he, wie  }
                                        { er in der MOD-Datei steht  }
 ziel : pt;                             { Abspielpuffer im pt-Format }
 Modp  : pointer;                       { Pointer auf Rm_Song        }
 note : array[1..8] of byte;
 altx,alty : integer;
 aktuelle_stimme : word;

 Mixed_data   : pointer;
 Mixed_data_st : pointer;

{$L modmix}
procedure Leere_stimme; external;
{procedure stimme_normal(aktuelle_stimme : word); external;}
procedure stimme_normal; external;
procedure stimme_normal_st; external;

var Portamento_Up_Stimme : array[1..8] of longint;
    Portamento_Do_Stimme : array[1..8] of longint;

var Mixingprocs         :  array[1..8] of pointer;
    Leerstimme          : pointer;

    effekt_Stimme     : array[1..8] of byte;

    Laenge_Stimme       : array[1..8] of longint;
    Loop_Laenge_Stimme  : array[1..8] of longint;
    Position_Stimme     : array[1..8] of longint;
    Loop_Start_Stimme   : array[1..8] of longint;
    Segment_Stimme      : array[1..8] of longint;
    Notvol_Stimme       : array[1..8] of longint;
    Incval_Stimme       : array[1..8] of longint;

var nothin_done_count : word;

    var bsw : boolean;
      vocb1,
      vocb2,
      buffer1,
      buffer2 : pointer;
    shiftfactor,
    shiftfactor_stereo : word;

{

 **************************************************************************
 ***                                                                    ***
 ***                Routinen  zum  Timer - Handling                     ***
 ***                                                                    ***
 **************************************************************************

}

procedure StelleTimerEin(Proc : pointer; Freq : word);
var izaehler : word;
    oldv : pointer;
begin;
 asm cli end;
 izaehler := 1193180 DIV Freq;
 Port[$43] := $36;
 Port[$40] := Lo(IZaehler);
 Port[$40] := Hi(IZaehler);

 Getintvec(8,OldV);
 setintvec(OldTimerInt,OldV);
 SetIntVec(8,Proc);
 old_tZaehler := 1;
 seczaehler  := 0;
 Altintzaehler := 0;
 asm sti end;
end;

procedure StelleTimerAus;
var oldv : pointer;
begin;
  asm cli end;
  port[$43] := $36;
  Port[$40] := 0;
  Port[$40] := 0;
  GetIntVec(OldTimerInt,OldV);
  SetIntVec(8,OldV);
  asm sti end;
end;

procedure NeuerTimer; interrupt;
var dr : registers;
begin;
 inc(nothin_done_count);
 inc(Seczaehler);
 inc(Altintzaehler);
 if Altintzaehler = 58 then begin;
   Altintzaehler := 0;
   intr(Oldtimerint,dr);
 end;
 if Seczaehler = timer_per_second then begin;
   Seczaehler := 0;
   inc(andycount);
   inc(Laufsec);
   if Laufsec = 60 then begin;
     inc(Laufmin);
     Laufsec := 0;
   end;
 end;
 if not in_retrace then calculate_Music;
 Port[$20] := $20;
end;


{

 **************************************************************************
 ***                                                                    ***
 ***              Routinen zur Ansteuerung des Soundblasters            ***
 ***                                                                    ***
 **************************************************************************

}


procedure wr_dsp_sb16(v : byte);
{
 Wartet, bis der DSP zum Schreiben bereit ist, und schreibt dann das
 in "v" bergebene Byte in den DSP
}
begin;
  while port[dsp_adr+$c] >= 128 do ;
  port[dsp_adr+$c] := v;
end;

FUNCTION SbReadByte : BYTE;
{
 Die Function wartet, bis der DSP gelesen werden kann und liefert den
 gelesenen Wert zurck
}
begin;
  while port[dsp_adr+$a] = $AA do ;     { warten, bis DSP ready      }
  SbReadByte := port[dsp_adr+$a];       { Wert schreiben             }
end;

procedure SBreset;
VAR bt,ct, stat : BYTE;
begin;
  PORT[dsp_adr+$6] := 1;                { dsp_adr+$6 = Resettfunktion}
  FOR ct := 1 TO 100 DO;
  PORT[dsp_adr+$6] := 0;
  bt := 0;
  repeat
    ct := 0;
    repeat
      stat := port[dsp_adr + $E];
    until (ct > 8000) or (stat >= 128);
    inc(bt);
  until (bt > 100) or (port[dsp_adr + $A] = $AA);
end;

FUNCTION Reset_sb16 : BOOLEAN;
{
 Die Function resetet den DSP. War das Resetten erfolgreich, wird
 TRUE zurckgeliefert, ansonsten FALSE
}
CONST  ready = $AA;
VAR ct, stat : BYTE;
BEGIN
  PORT[dsp_adr+$6] := 1;                { dsp_adr+$6 = Resettfunktion}
  FOR ct := 1 TO 100 DO;
  PORT[dsp_adr+$6] := 0;
  stat := 0;
  ct   := 0;                            { Der Vergleich ct < 100, da }
  WHILE (stat <> ready)                 { die Initialisierung ca.    }
  AND   (ct < 100)      DO BEGIN        { 100ms dauert               }
    stat := PORT[dsp_adr+$E];
    stat := PORT[dsp_adr+$a];
    INC(ct);
  END;
  Reset_sb16 := (stat = ready);
END;

FUNCTION Detect_Reg_sb16 : BOOLEAN;
{
 Die Funktion liefert TRUE zurck, wenn ein Soundblaster initialisiert
 werden konnte, ansonsten FALSE. Die Variable dsp_adr wird auf die
 Base-Adresse des SB gesetzt.
}
VAR
  Port, Lst : WORD;
BEGIN
 Detect_Reg_sb16 := SbRegDetected;
 IF SbRegDetected THEN EXIT;            { Exit, wenn initialisiert   }
 Port := Startport;                     { M”gliche SB-Adressen zwi-  }
 Lst  := Endport;                       { schen $210 und $280 !      }
 WHILE (NOT SbRegDetected)
 AND   (Port <= Lst)  DO BEGIN
   dsp_adr := Port;
   SbRegDetected := Reset_sb16;
   IF NOT SbRegDetected THEN
     INC(Port, $10);
 END;
 Detect_Reg_sb16 := SbRegDetected;
END;

PROCEDURE Write_Mixer(Reg, Val: BYTE);
{
 Schreibt den in Val bergebenen Wert an das in Reg angegebene
 Register des Mixer - Chips
}
begin;
 Port[dsp_adr+$4] := Reg;
 Port[dsp_adr+$5] := Val;
END;


FUNCTION Read_Mixer(Reg: BYTE) : BYTE;
{
 Die Function liefert den Inhalt des ber Reg indizierten Registers
 des Mixer-Chips
}
begin;
  Port[dsp_adr+$4] := Reg;
  Read_Mixer := Port[dsp_adr+$5];
end;

procedure Filter_Ein;
{
 Diese Procedure Stellt den Tiefen Filter ein bzw. regelt das
 Bass/Treble Register entsprechend
}
var hilfe : byte;
begin;
 if sb16detected then begin;
   write_Mixer(68,64);                  { Treble runter              }
   write_Mixer(69,64);
   write_Mixer(70,255);                 { Bass voll Power !          }
   write_Mixer(71,255);                 { Bass voll Power !          }
 end else begin;
   hilfe := read_Mixer($0c);            { Tiefer Filter              }
   hilfe := hilfe or 8;
   Write_Mixer($0c,hilfe);
   hilfe := read_Mixer($0e);            { Filter einschalten         }
   hilfe := hilfe AND 2;
   write_Mixer($0e,hilfe);
 end;
end;

procedure Filter_MID;
{
 Diese Procedure Stellt den Tiefen Filter ein bzw. regelt das
 Bass/Treble Register entsprechend
}
var hilfe : byte;
begin;
 if sb16detected then begin;
   write_Mixer(68,160);                  { Treble runter              }
   write_Mixer(69,160);
   write_Mixer(70,192);                 { Bass voll Power !          }
   write_Mixer(71,192);                 { Bass voll Power !          }
 end else begin;
   hilfe := read_Mixer($0e);            { Filter ausschalten         }
   hilfe := hilfe OR 32;
   write_Mixer($0e,hilfe);
 end;
end;

procedure Filter_aus;
var hilfe : byte;
begin;
 if sb16detected then begin;
   write_Mixer(68,192);                 { zurck auf default         }
   write_Mixer(69,192);
   write_Mixer(70,160);
   write_Mixer(71,160);
 end else begin;
   hilfe := read_Mixer($0c);            { H”hen-Filter               }
   hilfe := hilfe OR 247;
   Write_Mixer($0c,hilfe);
   hilfe := read_Mixer($0e);            { Filter einschalten         }
   hilfe := hilfe AND 2;
   write_Mixer($0e,hilfe);
 end;
end;

procedure Set_Balance(Wert : byte);
{
 Die Procedure Setzt die Balance entsprechend dem bergebenen Wert.
 Dabei steht 0 fr ganz links, 12 fr Mitte und 24 fr ganz rechts
}
Var left,right : byte;
begin;
 if Sb16Detected then begin;
   left  := 12;
   right := 12;
   if Wert < 12 then right := wert;
   if Wert > 12 then left  := 24-Wert;
   write_Mixer(50,(left  shl 4));
   write_Mixer(51,(right shl 4));
 end else begin;
  Wert := Wert SHR 1;
  case Wert of
     0..6 : begin;
               write_Mixer(02,(7 shl 5)+(Wert shl 1));
             end;
       07 : begin;
               write_Mixer(02,(7 shl 5)+(7 shl 1));
             end;
	  08..13 : begin;
               write_Mixer(02,((13-Wert) shl 5)+(7 shl 1));
	           end;
	 end;
 end;
end;

procedure Set_Volume(Wert : byte);
{
 Zum Setzen der Abspiel-Lautst„rke. Zul„ssige Werte von 0 bis 31
}
begin;
  if sb16detected then begin;
    write_Mixer(48,(Wert shl 3));
    write_Mixer(49,(Wert shl 3));
  end else begin;
    if MixerDetected then begin;
      Wert := Wert Shr 2;
      write_Mixer($22,(wert shl 5) + (wert shl 1));
    end else begin;
      outvolume := Wert shl 1;
    end;
  end;
end;

procedure reset_Mixer; assembler;
{
 Resettet den Mixer Chip auf seine Default - Werte
}
asm
  mov dx,dsp_adr+$4
  mov al,0
  out dx,al
  mov cx,50
@loop:
  loop @loop
  inc dx
  out dx,al
end;

FUNCTION Detect_Mixer_sb16 : BOOLEAN;
{
 Function zu Erkennung des Mixer-Chips. TRUE, wenn der Mixer gefunden
 wurde, ansonsten FALSE
}
VAR SaveReg : WORD;
    NewReg  : WORD;
BEGIN
  Detect_Mixer_sb16 := MixerDetected;
  IF (NOT SbRegDetected)                { Abbruch, wenn keine Sound- }
  OR MixerDetected THEN EXIT;           { blaster-Karte vorhanden    }
                                        { oder Mixer-Chip schon      }
                                        { initalisiert               }
  Reset_Mixer;
  SaveReg := Read_Mixer($22);           { Register sichern           }
  Write_Mixer($22, 243);                { Wenn der geschribene wert  }
  NewReg  := Read_Mixer($22);           { mit dem zurckgelesenen    }
                                        { bereinstimmt, so ist ein  }
                                        { Zugriff m”glich und somit  }
                                        { ein Mixer vorhanden        }
  IF NewReg = 243 THEN begin;
    MixerDetected := TRUE;
    STEREO := True;
  end;
  Write_Mixer($22, SaveReg);            { Altes Register zurck      }
  Detect_Mixer_sb16 := MixerDetected;
END;

PROCEDURE SbGetDSPVersion;
VAR i : WORD;
    t : WORD;
    s : STRING[2];
BEGIN
  wr_dsp_sb16($E1);                     { $E1 = Versionsabfrage      }
  SbVersMaj := SbReadByte;
  SbVersMin := SbReadByte;
  str(SbVersMaj, SbVersStr);
  SbVersStr := SbVersStr + '.';
  str(SbVersMin, s);
  if SbVersMin > 9 then
    SbVersStr := SbVersStr +       s
  else
    SbVersStr := SbVersStr + '0' + s;
END;

function wrt_dsp_adr_sb16 : string;
{
 Liefert die Base-Adresse des SB als String zurck
}
begin;
  case dsp_adr of
    $210 : wrt_dsp_adr_sb16 := '210';
    $220 : wrt_dsp_adr_sb16 := '220';
    $230 : wrt_dsp_adr_sb16 := '230';
    $240 : wrt_dsp_adr_sb16 := '240';
    $250 : wrt_dsp_adr_sb16 := '250';
    $260 : wrt_dsp_adr_sb16 := '260';
    $270 : wrt_dsp_adr_sb16 := '270';
    $270 : wrt_dsp_adr_sb16 := '280';
   END;
end;

function wrt_dsp_irq : string;
{
 Liefert den IRQ des SB als String zurck
}
begin;
  case dsp_irq of
     $2 : wrt_dsp_irq := '2 h';
     $3 : wrt_dsp_irq := '3 h';
     $5 : wrt_dsp_irq := '5 h';
     $7 : wrt_dsp_irq := '7 h';
    $10 : wrt_dsp_irq := '10 h';
   END;
end;

procedure Set_Timeconst_sb16(tc : byte);
{
 Procedure zum setzen der Time-Konstanten. Sie berechnet sich nach der
 Formel  tc := 256 - (1000000 / Frequenz).
}
begin;
  wr_dsp_sb16($40);                     { $40 = Setze Sample Rate    }
  wr_dsp_sb16(tc);
end;

procedure test_uebertragung;
begin;
   fillchar(buffer1^,3000,127);
   blockgroesse := 2000;
   letzte_ausgabe := true;
   Sampling_Rate := 211;
   dsp_block_sb16(blockgroesse,blockgroesse,buffer1,true,false);
   delay(100);
end;

procedure write_sbConfig;
{
 Die Procedure gibt die gefundene Konfiguration auf dem Bildschirm
 aus. Sie dient vornehmlich als Beispiel, wie die Informationen
 verwendet werden k”nnen
}
begin;
  clrscr;
  if SbRegDetected then begin;
    writeln('Soundkarte an Base ',wrt_dsp_adr_sb16,'h mit IRQ ',
    wrt_dsp_irq,' gefunden.');
  end else begin;
    writeln('Keine Soundblaster-kompatibele Karte gefunden !');
  end;
  if MixerDetected then begin;
    writeln('Mixer - Chip gefunden');
    if SbVersMaj < 4 then
      writeln('Die gefundene Karte ist',
			' ein Soundblaster Pro oder kompatibel')
    else
      writeln('Die gefundene Karte ist',
      ' ein Soundblaster 16 ASP oder kompatibel');
  end else begin;
    writeln('Die gefundene Karte ist',
    ' ein Soundblaster oder kompatibel');
  end;
  writeln('Die Versionsnummer lautet ',SbVersStr);
end;

procedure Exit_Sb16;
{
 Diese Prozedur wir beim Beenden des Programms aufgerufen und setzt
 den verbogenen DMA-Interrupt auf seinen Ausgangswert
}
begin;
  setintvec($8+dsp_irq,oldint);         { Alten Interrupt wieder her-}
  port[$21] := Port[$21] or irqmsk;     { stellen und Maskierung auf }
  port[dsp_adr+$c] := $d3;              { alten Wert zurck          }
  Port[$20] := $20;
  wr_dsp_sb16($D0);
end;

procedure Spiele_Sb16(Segm,Offs,dgr,dsize : word);
{
 Diese Procedure spielt den ber Segm:Offs adressierten Block mit der
 GrӇe dsize ab. Es ist darauf zu achten, das der DMA-Controller NICHT
 Seitenbergreifend arbeiten kann ...
}
var li : word;
begin;
  port[$0A] := dma_ch+4;                { DMA-Kanal sperren          }
  Port[$0c] := 0;                       { Adresse des Puffers   }
  Port[$0B] := $48+dma_ch;                     { fr Soundausgabe           }
  Port[dma_adr[dma_ch]] := Lo(offs);    { an DMA-Controller          }
  Port[dma_adr[dma_ch]] := Hi(offs);
  Port[dma_wc[dma_ch]] := Lo(dgr-1);  { GrӇe des Blockes (block-  }
  Port[dma_wc[dma_ch]] := Hi(dgr-1);  { groesse) an DMA-Controller }
  Port[dma_page[dma_ch]] := Segm;
  if sb16_outputlaenge <> dsize then begin;
    wr_dsp_sb16($C6);                   { DSP-Befehl 8-Bit ber DMA  }
    if stereo then begin;               { fr SB16 Nur zum Starten ! }
      wr_dsp_sb16($20);
{      write('õ');}
    end else
      wr_dsp_sb16($00);
    wr_dsp_sb16(Lo(dsize-1));           { GrӇe des Blockes an       }
    wr_dsp_sb16(Hi(dsize-1));           { den DSP                    }
    sb16_outputlaenge := dsize;
  end else begin;
    wr_dsp_sb16($45);                   { DMA Continue SB16 8-Bit    }
  end;
  Port[$0A] := dma_ch;                  { DMA-Kanal freigeben        }
end;

procedure Spiele_Sb(Segm,Offs,dgr,dsize : word);
{
 Diese Procedure spielt den ber Segm:Offs adressierten Block mit der
 GrӇe dsize ab. Es ist darauf zu achten, das der DMA-Controller NICHT
 Seitenbergreifend arbeiten kann ...
}
var li : word;
begin;
  port[$0A] := dma_ch+4;                { DMA-Kanal sperren          }
  Port[$0c] := 0;                       { Adresse des Puffers   }
  Port[$0B] := $48+dma_ch;                     { fr Soundausgabe           }
  Port[dma_adr[dma_ch]] := Lo(offs);    { an DMA-Controller          }
  Port[dma_adr[dma_ch]] := Hi(offs);
  Port[dma_wc[dma_ch]] := Lo(dgr-1);  { GrӇe des Blockes (block-  }
  Port[dma_wc[dma_ch]] := Hi(dgr-1);  { groesse) an DMA-Controller }
  Port[dma_page[dma_ch]] := Segm;
  wr_dsp_sb16($14);
  wr_dsp_sb16(Lo(dsize-1));             { GrӇe des Blockes an       }
  wr_dsp_sb16(Hi(dsize-1));             { den DSP                    }
  Port[$0A] := dma_ch;                  { DMA-Kanal freigeben        }
end;

procedure Spiele_SbPro(Segm,Offs,dgr,dsize : word);
{
 Diese Procedure spielt den ber Segm:Offs adressierten Block mit der
 GrӇe dsize ab. Es ist darauf zu achten, das der DMA-Controller NICHT
 Seitenbergreifend arbeiten kann ...
}
var li : word;
begin;
  port[$0A] := dma_ch+4;                { DMA-Kanal sperren          }
  Port[$0c] := 0;                       { Adresse des Puffers  }
  Port[$0B] := $48+dma_ch;                     { fr Soundausgabe           }
  Port[dma_adr[dma_ch]] := Lo(offs);    { an DMA-Controller          }
  Port[dma_adr[dma_ch]] := Hi(offs);
  Port[dma_wc[dma_ch]] := Lo(dgr-1);  { GrӇe des Blockes (block-  }
  Port[dma_wc[dma_ch]] := Hi(dgr-1);  { groesse) an DMA-Controller }
  Port[dma_page[dma_ch]] := Segm;

  wr_dsp_sb16($48);
  wr_dsp_sb16(Lo(dsize-1));             { GrӇe des Blockes an       }
  wr_dsp_sb16(Hi(dsize-1));             { den DSP                    }
  wr_dsp_sb16($91);
  Port[$0A] := dma_ch;                  { DMA-Kanal freigeben        }
end;

procedure dsp_block_sb16(gr,dgr : word;bk : pointer;b1,b2 : boolean);
{
 Diese Procedure startet die Ausgabe des Daten-Blocks mit der
 Gr”áe blockgroesse ber DMA
}
var l : longint;
    pn,offs : word;
    hbyte : byte;
    a : word;
    OldV,NewV,Hilfe : byte;
    stereoreg : byte;
    sr : word;
    samps : byte;
begin;
  PLAYING_MOD := b1;
  PLAYING_VOC := b2;

  dsp_rdy_sb16 := false;
  l := 16*longint(pt(bk).sgm)+pt(bk).ofs;
  pn := pt(l).sgm;
  offs := pt(l).ofs;

  if PLAYING_MOD then begin;
    set_timeconst_sb16(Sampling_Rate);
    if sb16Detected then begin;
      if stereo then  begin;
        Spiele_Sb16(pn,offs,dgr*2,gr*2);
{        write('S');}
      end else
        Spiele_Sb16(pn,offs,dgr,gr);
    end else begin;
      if stereo then begin;
        SR := word(-1000000 DIV (Sampling_Rate-256));
        SR := SR * 2;
        Samps := 256 - (1000000 DIV SR);
        set_timeconst_sb16(Samps);
        Spiele_SbPro(pn,offs,dgr*2,gr*2);
      end else
        Spiele_Sb(pn,offs,dgr,gr);
    end;
  end;

  if PLAYING_VOC then begin;
    sb16_outputlaenge := 0;
    set_timeconst_sb16(vblock.SR);
    if sb16Detected then begin;
      if stereo then begin;
        Spiele_Sb16(pn,offs,dgr,gr);
      end else begin;
        Spiele_Sb16(pn,offs,dgr,gr);
      end;
    end else begin;
      if stereo then begin;
        Spiele_SbPro(pn,offs,dgr,gr);
      end else begin;
        Spiele_Sb(pn,offs,dgr,gr);
      end;
    end;
  end;
end;


{

 **************************************************************************
 ***                                                                    ***
 ***                Routinen zum Abspielen von MOD-Dateien              ***
 ***                                                                    ***
 **************************************************************************

}

procedure get_pctunel(hoehe : word;Var vk : longint);
{
 Die Procedure ermittelt aus der bergebenen Tonh”he (so wie sie in
 der MOD-Datei steht) die fr die Frequenz-Manipulation ben”tigten
 Vor- und Nachkommastellen.
}
var nct : byte;
    gefunden : boolean;
begin;
 nct := 1;
 gefunden := false;
 while (nct <= 70) and not gefunden do   { Bis gefunden oder letzter  }
 begin;                                 { Wert in Tabelle            }
   if hoehe > Modoktave[nct] then
     gefunden := true;
   inc(nct);
 end;
 if gefunden then begin;
   vk  := Incfacts[nct-tpw+12];
 end else begin;
   vk  := 0;              { Werte aus Tabelle holen.   }
 end;
end;


{function T_Hoehe(Nr : word) : integer;
begin;
 T_Hoehe := Modoktave[nr];
end;}

function Noten_Nr(hoehe : word) : integer;
var nct : byte;
    gefunden : boolean;
begin;
 nct := 1;
 gefunden := false;
 while (nct <= 70) and not gefunden do   { Bis gefunden oder letzter  }
 begin;                                 { Wert in Tabelle            }
   if hoehe > Modoktave[nct] then
     gefunden := true;
   inc(nct);
 end;
 if gefunden then begin;
   Noten_nr := nct-1;
 end else begin;
   Noten_nr := -1;
 end;
end;

function Notenvolumen(Stm : byte) : byte;
begin;
 Notenvolumen := Rm_Song[mli,Stm,4];
end;

var mixed_posi : word;
    calc_size : word;

procedure innen_schleife_4;
{
 Hier erfolgt die eigentliche Vermischung der Daten. Der Puffer
 wird dabei mit den berechneten Daten gefllt. Dies ist die
 MONO-Version der Routine.
}
begin;
  calc_size := blockgroesse;
  if bsw then
    ziel := pt(buffer1)
  else
    ziel := pt(buffer2);
  fillchar(mixed_data^,8000,128);
asm

    mov cx,1
@stimmen_loop:
    mov mixed_posi,0
    mov aktuelle_stimme,cx
    mov si,cx
    dec si
    shl si,2
    call dword ptr Mixingprocs[si]

    inc cx
    cmp cx,stimmen
    jbe @stimmen_loop

    mov mixed_posi,0
    mov cx,calc_size
@Mixed_2_blk:
    les di,mixed_data
    add di,mixed_posi
    mov ax,es:[di]
    push cx
    mov cx,shiftfactor
    shr ax,cl
    pop cx
    add mixed_posi,2

    mov bx,ziel.sgm   							    { Byte ins Ziel schreiben    }
    mov es,bx
    mov bx,ziel.ofs
    mul outvolume
    shr ax,6
    mov es:[bx],al
    inc ziel.ofs

    loop @mixed_2_blk
end;
end;

procedure innen_schleife_4_stereo;
{
 Hier erfolgt die eigentliche Vermischung der Daten. Der Puffer
 wird dabei mit den berechneten Daten gefllt. Dies ist die
 MONO-Version der Routine.
}
begin;
  calc_size := blockgroesse;
  if bsw then
    ziel := pt(buffer1)
  else
    ziel := pt(buffer2);
  fillchar(mixed_data^,8000,128);
  fillchar(mixed_data_st^,8000,128);
asm
    mov cx,1
@stimmen_loop:
    mov mixed_posi,0
    mov aktuelle_stimme,cx
    mov si,cx
    dec si
    shl si,2
    call dword ptr Mixingprocs[si]

    inc cx
    cmp cx,stimmen
    jbe @stimmen_loop

    mov mixed_posi,0
    mov cx,calc_size
@Mixed_2_blk:
    les di,mixed_data
    add di,mixed_posi
    mov ax,es:[di]
    push cx
    mov cx,shiftfactor_stereo
    shr ax,cl
    pop cx

    mov bx,ziel.sgm   							    { Byte ins Ziel schreiben    }
    mov es,bx
    mov bx,ziel.ofs
    mul outvolume
    shr ax,6
    mov es:[bx],al
    inc ziel.ofs

    les di,mixed_data_st
    add di,mixed_posi
    mov ax,es:[di]
    push cx
    mov cx,shiftfactor_stereo
    shr ax,cl
    pop cx
    add mixed_posi,2

    mov bx,ziel.sgm   							    { Byte ins Ziel schreiben    }
    mov es,bx
    mov bx,ziel.ofs
    mul outvolume
    shr ax,6
    mov es:[bx],al
    inc ziel.ofs

    loop @mixed_2_blk
end;
end;

procedure vermische_start_4;
var rdiff : real;
    dummy : byte;
    var li : integer;
begin;
 for li := 1 to Stimmen do begin;
   if note[li] <> 0 then begin;
     tonhoehe_Stimme[li] := (Rm_Song[mli,li,1] and $0F)*256+Rm_Song[mli,li,2];
     get_pctunel(tonhoehe_Stimme[li],Incval_Stimme[li]);
   end;

   ls[li] := loop_s[In_st[li]];
   ll[li] := loop_l[In_st[li]];
   if ll[li] > 30 then inl[li] := ll[li]+ls[li];
   Loop_Laenge_Stimme[li] := ll[li];
   Loop_Start_Stimme[li]  := ls[li];

   case effekt_Stimme[li] of
     1 : begin;
            inc(Incval_Stimme[li],Portamento_up_Stimme[li]);
         end;
     2 : begin;
            inc(Incval_Stimme[li],Portamento_do_Stimme[li]);
         end;
   end;
 end;
end;


procedure effect_handling(li : integer);
var idx : word;
    Portamento_Speed : word;
    Startnote,
    endnote : word;
    startinc,
    endinc : longint;

begin;
 if Rm_Song[mli,li,3] and $0F <= 15 then begin;
   Eff[li] := 0;
   case (Rm_Song[mli,li,3] and $0F) of
      01 : begin;
             effekt_Stimme[li] := 1;
             Portamento_Speed := Rm_Song[mli,li,4];
             Startnote := Noten_nr(tonhoehe_Stimme[li]);
             Endnote   := Startnote+Portamento_Speed;
             get_pctunel(Modoktave[Startnote],Startinc);
             get_pctunel(Modoktave[Endnote],Endinc);
             Portamento_up_Stimme[li] := round((Endinc - Startinc) / playspeed);
           end;
      02 : begin;
             effekt_Stimme[li] := 2;
             Portamento_Speed := Rm_Song[mli,li,4];
             Startnote := Noten_nr(tonhoehe_Stimme[li]);
             Endnote   := Startnote-Portamento_Speed;
             get_pctunel(Modoktave[Startnote],Startinc);
             get_pctunel(Modoktave[Endnote],Endinc);
             Portamento_do_Stimme[li] := round((Endinc - Startinc) / playspeed);
           end;
       9 : begin;  { Sample offset }
             Position_Stimme[li] := longint(Rm_Song[mli,li,4]) shl 24;
           end;
      13 : begin;
			       mli := 64;
			     end;
      11 : begin;
			       mli := 64;
						 mlj := Rm_Song[mli,li,4];
			     end;
      12 : begin;
             Notvol_Stimme[li]  := Notenvolumen(li);
           end;
      14 : begin;
             case (Rm_Song[mli,li,4] shr 4) of
                12 : begin;
                       inl[li]    := 0;
                       Notvol_Stimme[li]   := 0;
                       inp[li]    := 0;
                       Pnk[li]    := 0;
                     end;
             end;
           end;
      15 : begin;
             idx := Rm_Song[mli,li,4];
             if idx <= $f then begin;
               Playspeed    := idx;
               Speed := Playspeed*105 div 10;
               blockgroesse := Speed * Sound_Schleifen;
             end else begin;
               bpm := idx;
               mod_SetLoop(Sampling_Frequenz div (BPM * 4));
               Speed := Playspeed*105 div 10;
               blockgroesse := Speed * Sound_Schleifen;
             end;
             if blockgroesse < 40 then blockgroesse := 40;
             if blockgroesse > 4000 then blockgroesse := 4000;
			     end;
    end;
  end;
end;

procedure nmw_all_4;
const stereoprocs : array[1..8] of pointer =
  (@Stimme_normal,@Stimme_normal,@Stimme_normal_st,@Stimme_normal_st,
   @Stimme_normal,@Stimme_normal,@Stimme_normal_st,@Stimme_normal_st);
var idx : byte;
    li : integer;
begin;
   inc(mli);
   if mli > 64 then mli := 1;
   if mli = 1 then begin;
     inc(mlj);
     if mlj > Liedlaenge then begin;
       if mloop then begin;
         mlj := 1;
         move(rm[lied[mlj]] ^,Rm_Song,2048);
       end else begin;
         asm
           call [periodisch_anhalten]
         end;
         music_aus := true;
         Mod_Zu_Ende := true;
       end;
     end else begin;
         move(rm[lied[mlj]] ^,Rm_Song,2048);
     end;
   end;

  for li := 1 to Stimmen do begin;
    effekt_Stimme[li] := 0;
    note[li] := (Rm_Song[mli,li,1] AND $F0)+((Rm_Song[mli,li,3] AND $F0) shr 4);
    if note[li] <> 0 then begin;
      if stereo then begin;
        Mixingprocs[li] := stereoprocs[li];
      end else begin;
        Mixingprocs[li] := @Stimme_normal;
      end;
      Noten_Anschlag[li] := 500;
      In_St[li]  := note[li];
      inst[li]  := Ptr(pt(Samp[In_St[li]]).sgm,pt(Samp[In_St[li]]).ofs);
      Laenge_Stimme[li]      := sam_l[In_St[li]];
      Position_Stimme[li]    := 0;
      Notvol_Stimme[li]      := inst_vol[in_St[li]];
      Segment_Stimme[li]     := seg(inst[li]^);
    end;
    effect_handling(li);
  end;

end;


procedure initialisiere_vermischen;
begin;
  asm
    call [vermische_proc]
  end;
end;

FUNCTION ConvertString(Source : Pointer; Size : BYTE):String;
VAR
   WorkStr : String;
BEGIN
   Move(Source^,WorkStr[1],Size);
   WorkStr[0] := CHR(Size);
   ConvertString := WorkStr;
END;

function init_Song : boolean;
const kenn1 : string = 'FLT4';
      kenn2 : string = 'M.K.';
      kenn3 : string = '8CHN';
var rmod : file;
    sgr : word;                         { GrӇe eines Sampels        }
    inststart : longint; { Position in Datei, wo Sampledaten starten }
    datgr : longint;                    { Die GrӇe der MOD - Datei  }
    Mkg : array[1..4] of char;          { fr Modtyp - Erkennung     }
    hilfsp : ^byte;
    strptr : pointer;
    kennch : array[1..4] of char;
    kennstr : string;
    instanz : byte;
    idx : integer;
begin;
 In_St[1] := 0;
 In_St[2] := 0;
 In_St[3] := 0;
 In_St[4] := 0;
 In_St[5] := 0;
 In_St[6] := 0;
 In_St[7] := 0;
 In_St[8] := 0;
 for mlj := 0 to 128 do
   Lied[mlj] := 0;
 {$I-}
 assign(rmod,Mod_Name);
 reset(rmod,1);
 {$I+}
 if IOresult <> 0 then begin;
   init_song := false;
   exit;
 end;
 if moddatgroesse <> 0 then datgr := moddatgroesse else
 datgr := filesize(rmod);
 inststart := datgr;
 seek(rmod,1080);
 blockread(rmod,kennch,4);
 kennstr := kennch;
 if (kennstr <> kenn1) and (kennstr <> kenn2)
 and (kennstr <> kenn3) then begin;
   instanz := 15;
 end else begin;
   instanz := 31;
 end;

 if instanz = 31 then begin;  { 31 Stimmen ber Kennung ermittelt     }
 for mlj := 1 to 31 do begin;
  idx := mlj;
  seek(rmod,msp+42+(idx-1)*30);
  blockread(rmod,sgr,2);
  sgr := swap(sgr) * 2;
  if sgr <> 0 then inststart := inststart - sgr;
  Sam_l[idx] := sgr;
  seek(rmod,msp+45+(idx-1)*30);
  blockread(rmod,inst_vol[idx],1);
  blockread(rmod,loop_s[idx],2);
  blockread(rmod,loop_l[idx],2);
  loop_s[idx] := swap(loop_s[idx])*2;
  loop_l[idx] := swap(loop_l[idx])*2;
 end;

 seek(rmod,msp+1080);
 blockread(rmod,Mkg,4);
 if pos('8CHN',Mkg) <> 0 then begin;
   Pattgroesse    := 2048;
   Stimmen        := 8;
   shiftfactor        := 3;
   shiftfactor_stereo := 3;
 end else begin;
 { 4-Stimmige MOD-Datei }
   Pattgroesse    := 1024;
   Stimmen        := 4;
   shiftfactor        := 2;
   shiftfactor_stereo := 2;
 end;
 Vermische_Proc := @vermische_start_4;
 nmw_Proc       := @nmw_all_4;
 if stereo then
   innen_proc     := @innen_schleife_4_stereo
 else
   innen_proc     := @innen_schleife_4;


 seek(rmod,msp+inststart);
 for mlj := 1 to 31 do begin;
  idx := mlj;
  getmem(Samp[idx],Sam_l[idx]);
  blockread(rmod,Samp[idx]^,sam_l[idx]);
 end;

 datgr := inststart - 1083;
 pat_anz := datgr div Pattgroesse;
 for mlj := 0 to pat_anz-1 do begin;
   getmem(rm[mlj],2048);
   fillchar(rm[mlj]^,2048,0);
   seek(rmod,msp+1084+mlj*Pattgroesse);
   hilfsp := ptr(seg(rm[mlj]^),ofs(rm[mlj]^));
   for mli := 0 to 63 do begin;
     hilfsp := ptr(seg(rm[mlj]^),ofs(rm[mlj]^)+mli*32);
  	 blockread(rmod,hilfsp^,Pattgroesse div 64);
   end;
 end;
 seek(rmod,msp+952);
 blockread(rmod,Lied,128);

 getmem(strptr,25);
 for i := 0 to 30 do begin;
   seek(rmod,msp+20+i*30);
   blockread(rmod,strptr^,22);
   instnamen[i+1] := convertstring(strptr,22);
 end;
 seek(rmod,msp);
 blockread(rmod,strptr^,20);
 songname := convertstring(strptr,20);
 freemem(strptr,25);

 seek(rmod,msp+950); { von 470}
 blockread(rmod,Liedlaenge,1);
 end else begin;
 for mlj := 1 to 15 do begin;
  seek(rmod,msp+42+(mlj-1)*30);
  blockread(rmod,sgr,2);
  sgr := swap(sgr) * 2;
  if sgr <> 0 then inststart := inststart - sgr;
  Sam_l[mlj] := sgr;
  seek(rmod,msp+45+(mlj-1)*30);
  blockread(rmod,inst_vol[mlj],1);
  blockread(rmod,loop_s[mlj],2);
  blockread(rmod,loop_l[mlj],2);
  loop_s[mlj] := swap(loop_s[mlj])*2;
  loop_l[mlj] := swap(loop_l[mlj])*2;
 end;

 for mlj := 16 to 31 do begin;
  Sam_l[mlj] := 0;
  loop_s[mlj] := 0;
  loop_l[mlj] := 0;
 end;

 if pos('8CHN',Mkg) <> 0 then begin;
   Pattgroesse    := 2048;
   Stimmen        := 8;
   shiftfactor        := 3;
   shiftfactor_stereo := 3;
 end else begin;
 { 4-Stimmige MOD-Datei }
   Pattgroesse    := 1024;
   Stimmen        := 4;
   shiftfactor        := 2;
   shiftfactor_stereo := 2;
 end;
 Vermische_Proc := @vermische_start_4;
 nmw_Proc       := @nmw_all_4;
 if stereo then
   innen_proc     := @innen_schleife_4_stereo
 else
   innen_proc     := @innen_schleife_4;

 seek(rmod,msp+inststart);
 for mlj := 1 to 15 do begin;
   getmem(Samp[mlj],Sam_l[mlj]);
   blockread(rmod,Samp[mlj]^,sam_l[mlj]);
 end;

 datgr := inststart - 603;
 pat_anz := datgr div Pattgroesse;
 for mlj := 0 to pat_anz-1 do begin;
   getmem(rm[mlj],2048);
   fillchar(rm[mlj]^,2048,0);
   seek(rmod,msp+1084+mlj*Pattgroesse);
   hilfsp := ptr(seg(rm[mlj]^),ofs(rm[mlj]^));
   for mli := 0 to 63 do begin;
     hilfsp := ptr(seg(rm[mlj]^),ofs(rm[mlj]^)+mli*32);
  	 blockread(rmod,hilfsp^,Pattgroesse div 64);
   end;
 end;
 seek(rmod,msp+472);
 blockread(rmod,Lied,128);

 getmem(strptr,25);
 for i := 0 to 14 do begin;
   seek(rmod,msp+20+i*30);
   blockread(rmod,strptr^,22);
   instnamen[i+1] := convertstring(strptr,22);
 end;

 for i := 15 to 30 do begin;
   instnamen[i+1] := '';
 end;
 seek(rmod,msp);
 blockread(rmod,strptr^,20);
 songname := convertstring(strptr,20);
 freemem(strptr,25);

 seek(rmod,msp+470);
 blockread(rmod,Liedlaenge,1);
 end;


 mlj := 0;
 mli := 0;
 close(rmod);
 init_song := true;
end;

procedure exit_song;
begin;
 Port[dsp_adr+$C] := $D3;
 halt(0);
end;

procedure Free_Soundmem;
{
 Reservierten Speicher wieder frei geben
}
begin;
 if music_played then begin;
 for mlj := 0 to pat_anz-1 do begin;
   freemem(rm[mlj],2048);
 end;
 end;
end;

procedure init_sbperiod(p : pointer);
begin;
  periodisch_anhalten := p;
end;

procedure mod_SetLoopflag(loopen : boolean);
begin;
 mloop := loopen;
end;

procedure mod_SetMultiply(msm : word);
begin;
 modmultiply := msm;
end;

procedure mod_SetLoop(msl : word);
begin;
 Sound_Schleifen := msl;
 loop3 := msl;
end;

procedure mod_SetSpeed(msp : word);
begin;
 speed := msp;
 Speed3 := msp;
end;

procedure mod_autodetect(what : boolean);
begin;
 if what then mautodet := true else mautodet := false;
end;

procedure mod_transpose(transposerwert : integer);
begin;
  tpw := transposerwert;
end;

procedure init_data;
Var i,j : integer;
begin;
 m_played := false;
 In_St[1] := 0;
 In_St[2] := 0;
 In_St[3] := 0;
 In_St[4] := 0;
 In_St[5] := 0;
 In_St[6] := 0;
 In_St[7] := 0;
 In_St[8] := 0;
 Note1 := 0;
 Note2 := 0;
 Note3 := 0;
 Note4 := 0;
 Note5 := 0;
 Note6 := 0;
 Note7 := 0;
 Note8 := 0;
 Noten_Anschlag[1] := 0;
 Noten_Anschlag[2] := 0;
 Noten_Anschlag[3] := 0;
 Noten_Anschlag[4] := 0;
 Noten_Anschlag[5] := 0;
 Noten_Anschlag[6] := 0;
 Noten_Anschlag[7] := 0;
 Noten_Anschlag[8] := 0;
 fillchar(inl,sizeof(inl),0);
 notvol1 := 0; notvol2 := 0; notvol3 := 0; notvol4 := 0;
 notvol5 := 0; notvol6 := 0; notvol7 := 0; notvol8 := 0;
 fillchar(Rm_Song,2048,0);
end;

procedure init_Paramtable;
var ls : byte;
    h : real;
begin;
{  playspeed := 6;
  for ls := 1 to 31 do begin;
    if ls <= 3 then
      ModPara[ls].mult := 100
    else
      ModPara[ls].mult := 105;
    ModPara[ls].Speed := ls*ModPara[ls].mult div 10;
    ModPara[ls].bgr := ModPara[ls].Speed*Sound_Schleifen;
   end;}
end;

procedure mod_Samplefreq(Rate : integer);
var h : real;
begin;
  case Rate of
     08 : begin;
            Sampling_Rate := 131;
            set_timeconst_sb16(131);
            mod_transpose(1);
            mod_SetLoop(15);
            blockgroesse := Speed * Sound_Schleifen;
            Sampling_Frequenz := 8000;
            init_Paramtable;
          end;
     10 : begin;
            Sampling_Rate := 156;
            set_timeconst_sb16(156);
            mod_transpose(5);
            mod_SetLoop(19);
            blockgroesse := Speed * Sound_Schleifen;
            Sampling_Frequenz := 10000;
            init_Paramtable;
          end;
     13 : begin;
            Sampling_Rate := 181;
            set_timeconst_sb16(181);
            mod_transpose(10);
            mod_SetLoop(25);
            blockgroesse := Speed * Sound_Schleifen;
            Sampling_Frequenz := 13333;
            init_Paramtable;
          end;
     16 : begin;
            Sampling_Rate := 196;
            set_timeconst_sb16(196);
            mod_transpose(14);
            mod_SetLoop(32);
            blockgroesse := Speed * Sound_Schleifen;
            Sampling_Frequenz := 16666;
            init_Paramtable;
          end;
     22 : begin;
            Sampling_Rate := 211;
            set_timeconst_sb16(211);
            mod_transpose(19);
            mod_SetLoop(44);
            blockgroesse := Speed * Sound_Schleifen;
            Sampling_Frequenz := 22222;
            init_Paramtable;
          end;
   end;
end;

procedure Sound_handler;
var li : integer;
begin;
 if mycli <> 0 then exit;
 mycli := 1;
 if (Loop_pos > Speed) then begin;
   if phase_2 then begin;
     Nothin_done_count := 0;
     asm
       call [nmw_proc]
     end;
     Initialisiere_Vermischen;
     Loop_pos := 0;
     phase_2 := false;
     phase_1 := true;
     if outfading then
       if outvolume >= 2 then dec(outvolume,2);
     for li := 1 to 8 do
       if Noten_Anschlag[li] > 50 then dec(Noten_Anschlag[li],50);
   end;
 end else begin;
     asm call [innen_proc] end;
   Loop_pos := Speed+2;
 end;
 mycli := 0;
end;

procedure calculate_music; assembler;
asm
 cmp mycli,0
 jne  @ende_stop
 cmp  music_aus,0
 jne   @ende_stop
 pusha
 call Sound_handler
 popa
 @ende_stop:
end;

procedure mod_waitretrace(num : byte);
var dl : integer;
begin;
 in_retrace := true;
 for dl := 1 to num do
    calculate_music;
asm
  push dx
@l1:
  mov dx,3dah
  in al,dx
  and al,8h
  jnz @l1
@l2:
  mov dx,3dah
  in al,dx
  and al,8h
  jz @l2
  pop dx
End;
 in_retrace := false;
end;


function lade_moddatei(modname : string;ispeed,iloop : integer;freq : byte) : integer;
var df : file;
    sterreg : byte;
    fgr : longint;
begin;
 PLAYING_MOD := true;
 PLAYING_VOC := false;
 outfading := false;
 outvolume := 63;
 Mod_Name := modname;
 {$I-}
 assign(df,Mod_name);
 reset(df,1);
 {$I+}
 if IOResult <> 0 then begin;
   {$I-}
   close(df);
   lade_moddatei := -1;                 { Datei nicht gefunden !     }
   exit;
 end;
 {$I-}
 fgr := filesize(df);
 close(df);
 music_played := true;
 music_aus := false;
 Mod_zu_ende := false;

 if ispeed <> AUTO then Speed3 := ispeed;
 if iloop <> AUTO then Loop3  := iloop;
 if force_mono then stereo := false;
 if force_sb then begin;
   if Sb16Detected then stereo := false;
   Sb16Detected := false;
 end;

 if SBProdetected then begin;
   if stereo then begin;
     sterreg := Read_Mixer($0e);
     write_Mixer($0e,sterreg OR 2);
   end else begin;
     sterreg := Read_Mixer($0e);
     write_Mixer($0e,sterreg AND $FD);
   end;
 end;
 init_data;
 if init_song then begin;
   phase_1 := false;
   phase_2 := true;
   mycli := 0;

   mod_Samplefreq(freq);
   Playspeed    := 6;
   Speed := Playspeed*105 div 10;
   bpm := 125;
   mod_SetLoop(Sampling_Frequenz div (BPM * 4));
   blockgroesse := Speed * Sound_Schleifen;
   if blockgroesse < 100 then blockgroesse := 100;
   if blockgroesse > 4000 then blockgroesse := 4000;

   asm call [nmw_proc] end;
   set_timeconst_sb16(Sampling_Rate);
   Initialisiere_Vermischen;
   Laufsec := 0;
   Laufmin := 0;
   wr_dsp_sb16($D1);
   if sb16detected or sbprodetected then begin;
	   filter_Mid;
     Set_Balance(Balance);
     Set_Volume(Mastervolume);
   end;
   Lade_Moddatei := 0;
 end else begin;
   Lade_Moddatei := -3;  { Fehler beim Laden des Songs }
 end;
end;

procedure ende_mod;
var mlj : integer;
begin;
 Free_Soundmem;
 for mlj := 1 to 31 do begin;
   freemem(Samp[mlj],Sam_l[mlj]);
 end;
 mod_terminated := true;
end;


Procedure periodisch_on;
Begin
 outvolume := 64;
 letzte_ausgabe := false;
{ for Loop_pos := 1 to Speed do begin;}
   asm call [innen_proc] end;
{ end;}
 dsp_block_sb16(blockgroesse,blockgroesse,buffer1,true,false);
 bsw := not bsw;
 Loop_pos := 0;
 asm
   call [nmw_proc]
 end;
 Initialisiere_Vermischen;

 init_sbperiod(@periodisch_off);
 music_played := true;
 StelleTimerEin(@NeuerTimer,timer_per_second);
End;

Procedure periodisch_off;
Begin
  letzte_ausgabe := true;
  StelleTimerAus;
End;

procedure Fade_Musix_out;
begin;
  outfading := true;
end;

procedure MODExitProc;
var mlj : byte;
 begin
 ExitProc := SaveExitProc;
{ if music_played then periodisch_off;}
 if not mod_terminated and music_played then ende_mod;
 Exit_Sb16;
end;



{

 **************************************************************************
 ***                                                                    ***
 ***                 Routinen zur Ausgabe von VOC-Dateien               ***
 ***                                                                    ***
 **************************************************************************

}

var pause_voc : boolean;

procedure Init_Voc(filename : string);
const VOCkenn : string = 'Creative Voice File'+#$1A;
var ch : char;
    kennstr : string;
    ct : byte;
    h : byte;
    error : integer;
    srlo,srhi : byte;
    SR : word;
    Samplingr : word;
    stereoreg : byte;
begin;
  PLAYING_MOD := false;
  PLAYING_VOC := true;
  VOC_READY   := false;
  vocsstereo := stereo;
  stereo := false;

  assign(vocf,filename);
  reset(vocf,1);
  if filesize(vocf) < 5000 then begin;
    VOC_READY   := true;
    exit;
  end;
  blockread(vocf,voch,$19);
  kennstr := voch.Kennstr;
  if kennstr <> VOCkenn then begin;
    VOC_READY   := true;
    exit;
  end;

  Blockread(vocf,inread,20);
  vblock.Kennung := inread[2];

  if vblock.Kennung = 1 then begin;
    vblock.SR := inread[6];
  end;

  if vblock.Kennung = 8 then begin;
    SR := inread[6]+(inread[7]*256);
    Samplingr := 256000000 div (65536 - SR);
    if inread[9] = 1 then begin; {stereo}
      if sb16detected then samplingr := samplingr shr 1;
      stereo := true;
    end;
    vblock.SR := 256 - longint(1000000 DIV samplingr);
  end;

  if vblock.Kennung = 9 then begin;
    Samplingr := inread[6]+(inread[7]*256);
    if inread[11] = 2 then begin; {stereo}
      stereo := true;
      if sbprodetected then samplingr := samplingr * 2;
      vblock.SR := 256 - longint(1000000 DIV (samplingr));
    end else begin;
      vblock.SR := 256 - longint(1000000 DIV samplingr);
    end;
  end;


  if vblock.SR < 130 then vblock.SR := 166;

  set_timeconst_sb16(vblock.SR);

  blockgr := filesize(vocf) - 31;
  if blockgr > 2500 then blockgr := 2500;
  blockread(vocf,vocb1^,blockgr);

  ch := #0;
  fgr := filesize(vocf) - 32;
  fgr := fgr - blockgr;
  Block_activ := 1;

  if fgr > 1 then begin;
    blockread(vocf,vocb2^,blockgr);
    fgr := fgr - blockgr;
  end;

  wr_dsp_sb16($D1);
 lastone := false;

 if not sb16Detected then begin;
   if Stereo then begin;
     stereoreg := Read_Mixer($0E);
     stereoreg := stereoreg OR 2;
     Write_Mixer($0E,stereoreg);
   end else begin;
     stereoreg := Read_Mixer($0E);
     stereoreg := stereoreg AND $FD;
     Write_Mixer($0E,stereoreg);
   end;
 end;
 pause_voc := false;
 dsp_block_sb16(blockgr,blockgr,vocb1,false,true);
end;

procedure voc_done;
var h : byte;
begin;
 lastone := true;
{ repeat until dsp_rdy_sb16;}
 close(vocf);
 Reset_Sb16;
 stereo := vocsstereo;
end;


procedure voc_pause;
begin;
  pause_voc := true;
end;

procedure voc_continue;
begin;
  pause_voc := false;
  if block_activ = 1 then begin
    dsp_block_sb16(blockgr,blockgr,vocb2,false,true);
    block_activ := 2;
  end else begin;
    dsp_block_sb16(blockgr,blockgr,vocb1,false,true);
    block_activ := 1;
  end;
end;

{

 **************************************************************************
 ***                                                                    ***
 ***    Nochmals SB - Routinen, aus logischen Grnden nachgelagert      ***
 ***                                                                    ***
 **************************************************************************

}

procedure dsp_int_sb16; interrupt;
{
 Diese Procedure wird durch den Interrupt angesprungen, der am Ende
 einer Blockbertragung generiert wird. Wenn nicht das Flag
 letzte_ausgabe gesetzt ist, wird eine neue Ausgabe gestartet
}
var h : byte;
begin;
  if interrupt_check then begin;
    IRQDetected := true;
  end else begin;
    if PLAYING_MOD then begin;
      h := port[dsp_adr+$E];
      dsp_rdy_sb16 := true;

      if not letzte_ausgabe then begin;
        if bsw then
          dsp_block_sb16(blockgroesse,blockgroesse,buffer1,true,false)
        else
          dsp_block_sb16(blockgroesse,blockgroesse,buffer2,true,false);
        bsw := not bsw;
        phase_1 := false;
        phase_2 := true;
      end;
    end;

    IF PLAYING_VOC then begin;
      h := port[dsp_adr+$E];
      if (fgr > blockgr) and not lastone then begin
        lastone := false;
        if block_activ = 1 then begin
          if not pause_voc then
            dsp_block_sb16(blockgr,blockgr,vocb2,false,true);
          blockread(vocf,vocb1^,blockgr);
          fgr := fgr - blockgr;
          block_activ := 2;
        end else begin;
          if not pause_voc then
            dsp_block_sb16(blockgr,blockgr,vocb1,false,true);
          blockread(vocf,vocb2^,blockgr);
          fgr := fgr - blockgr;
          block_activ := 1;
        end;
      end else begin;
        if not lastone then begin;
          if block_activ = 1 then begin
            if not pause_voc then
              dsp_block_sb16(blockgr,blockgr,vocb2,false,true);
            lastone := true;
          end else begin;
            if not pause_voc then
              dsp_block_sb16(blockgr,blockgr,vocb1,false,true);
            lastone := true;
          end;
        end else begin;
          dsp_rdy_sb16 := true;
          wr_dsp_sb16($D0);
          VOC_READY := true;
        end;
      end;
    end;
  end;
  Port[$20] := $20;
end;

procedure detect_sbIRQ;
{
 Diese Routine erkennt den IRQ der Soundblaster-Karte. Es werden dazu
 alle m”glichen Interrupts durchgetestet. Dazu werden kurze Blocke
 via DMA ausgegeben. Wenn am Ende der Ausgabe der eingestellte Inter-
 rupt angesprungen wird, so ist der richtige gefunden
}
const moegliche_irqs : array[1..5] of byte = ($2,$3,$5,$7,$10);
var i : integer;
    h : byte;
begin;
 getintvec($8+dsp_irq,intback);         { Werte sichern !            }
 port21 := port[$21];
 fillchar(buffer1^,1200,128);
 set_Timeconst_sb16(211);
 wr_dsp_sb16($D3);                      { Lautsprecher aus           }
 i := 1;
 interrupt_check := true;
 while (i <= 5) and (not IRQDetected) do
   begin;
     dsp_irq := moegliche_irqs[i];      { zu Testender IRQ           }
     getintvec($8+dsp_irq,oldint);      { Interrupt Verbiegen        }
     setintvec($8+dsp_irq,@Dsp_Int_sb16);
     irqmsk := 1 shl dsp_irq;
     port[$21] := port[$21] and not irqmsk;
     Sampling_Rate := 211;
     blockgroesse := 1200;                { testweise Ausgabe          }
     dsp_block_sb16(blockgroesse,blockgroesse,buffer1,true,false);
     delay(150);
     setintvec($8+dsp_irq,oldint);      { Interrupt wieder zurck    }
     port[$21] := Port[$21] or irqmsk;
     h := port[dsp_adr+$E];
     Port[$20] := $20;
     inc(i);
   end;
 interrupt_check := false;
 wr_dsp_sb16($D1);                      { Lautsprecher wieder ein    }
 setintvec($8+dsp_irq,intback);         { Alte Werte zurck !!!      }
 port[$21] := port21;
 dsp_rdy_sb16 := true;
end;

function Init_Sb : boolean;
{
 Diese Function initialisiert den Soundblaster. Sie liefert TRUE
 zurck, wenn die Initialisierung erfolgreich war, ansonsten FALSE.
 Der Lautsprecher fr Sampling-Ausgabe wird eingeschaltet. Der
 DMA-Ready Interrupt wird auf eine eigene Routine verbogen.
}
begin;
  if not detect_Reg_sb16 then begin;
    Init_Sb := false;
    exit;
  end;
{ Soundblaster gefunden      }
 if not force_irq then detect_sbIRQ;    { IRQ auto-detection         }
   test_uebertragung;
 if not force_irq then detect_sbIRQ;    { 2. Test fr SB n”tig !     }
 if Detect_Mixer_sb16 then begin;
   SbProDetected := TRUE;               { SB Pro gefunden            }
 end;
 SbGetDspVersion;
 if SbVersMaj >= 4 then begin;                { SB 16 ASP gefunden         }
   Sb16Detected := true;
   SBProDetected := false;
 end;
 wr_dsp_sb16($D1);                      { Lautsprecher ein           }
 getintvec($8+dsp_irq,oldint);          { Alten Interrupt sichern,   }
 setintvec($8+dsp_irq,@dsp_int_sb16);   { auf eigene Routine setzen  }
 irqmsk := 1 shl dsp_irq;               { Interrupt einmaskieren     }
 port[$21] := port[$21] and not irqmsk;
end;

function init_The_Mod : boolean;
begin;
 mod_autodetect(on);  { Wenn true werden Speed-Angaben im Song erkannt      }
 mod_SetSpeed(66);
 mod_SetMultiply(11);
 mod_Setloopflag(ON); { Soll die Ausgabe wieder von Vorne beginnen, wenn am }
                      { Ende angekommen ?  (ON / OFF)                       }
 if not init_sb then             { Speaker einschalten, automatische Erkennung         }
   init_the_mod := false
 else begin;
   init_the_mod := true;
   mod_Samplefreq(Samfreq);
 end;
end;


begin;
 SaveExitProc := ExitProc;
 ExitProc := @MODExitProc;
 dsp_rdy_sb16 := true;
 mod_terminated := false;
 music_played := false;
 mloop := true;
 mli := 0;
 mlj := 0;
 tpw := 5;
 In_St[1] := 0;
 In_St[2] := 0;
 In_St[3] := 0;
 In_St[4] := 0;
 In_St[5] := 0;
 In_St[6] := 0;
 In_St[7] := 0;
 In_St[8] := 0;
 loop_pos := 0;
 mautodet := true;
 modmultiply := 20;
 Sound_Schleifen := 10;
 Noten_Anschlag[1] := 0;
 Noten_Anschlag[2] := 0;
 Noten_Anschlag[3] := 0;
 Noten_Anschlag[4] := 0;
 Noten_Anschlag[5] := 0;
 Noten_Anschlag[6] := 0;
 Noten_Anschlag[7] := 0;
 Noten_Anschlag[8] := 0;
 Leerstimme := @Leere_Stimme;
 Mixingprocs[1] := Leerstimme;
 Mixingprocs[2] := Leerstimme;
 Mixingprocs[3] := Leerstimme;
 Mixingprocs[4] := Leerstimme;
 Mixingprocs[5] := Leerstimme;
 Mixingprocs[6] := Leerstimme;
 Mixingprocs[7] := Leerstimme;
 Mixingprocs[8] := Leerstimme;
 getmem(mixed_data,8000);
 getmem(mixed_data_st,8000);

 getmem(buffer1,8000);
 getmem(buffer2,8000);
 getmem(vocb1,8000);
 getmem(vocb2,8000);
 bsw := true;
end.

unit variab;

interface

TYPE
  pt = record                           { erm”glicht die einfache    }
    ofs,sgm  :  word;                   { Behandlung von Pointern    }
  end;

  Effect_Type = record
     p : pointer;
     l : longint;
     sr : word;
   end;

  Param_Table = record
    mult  : word;
    Speed : word;
    bgr   : word;
    Ab    : integer;
   end;
TYPE vocheader = record
       Kennstr : array[0..19] of char;
       Sampoff : word;
       Verslo  : Byte;
       Vershi  : Byte;
       Kennung : word;
     end;

     Voiceblock = record
       Kennung  : byte;
       Laeng_lo : word;
       Laeng_hi : byte;
       SR       : byte;
       Pack     : byte;
     end;



CONST block_activ : byte = 1;
  Incfacts : array[1..99] of longint =
    ( $0021E7,$0023EB,$00260E,$002851,$002AB7,$002D41,$002FF2,$0032CC,
      $0035D1,$003904,$003C68,$004000,$0043CE,$0047D6,$004C1C,$0050A2,
      $00556E,$005A82,$005FE4,$006598,$006BA2,$007209,$0078D0,$007FFF,
      $00879C,$008FAC,$009837,$00A144,$00AADB,$00B504,$00BFC8,$00CB2F,
      $00D744,$00E411,$00F1A1,$00FFFF,$010F39,$011F5A,$013070,$01428A,
      $0155B8,$016A09,$017F91,$01965F,$01AE89,$01C823,$01E343,$01FFFF,
      $021E72,$023EB3,$0260DF,$028514,$02AB6F,$02D413,$02FF21,$032CC0,
      $035D14,$039047,$03C686,$03FFFF,$043CE4,$047D66,$04C1BF,$050A29,
      $0556E0,$05A827,$05FE43,$06597F,$06BA27,$07208F,$078D0D,$07FFFF,
      $0879C7,$08FACC,$09837E,$0A1451,$0AADC0,$0B504F,$0BFC87,$0CB2FF,
      $0D744F,$0E411F,$0F1A1C,$0FFFFF,$10F38F,$11F59A,$1306FE,$1428A3,
      $155B81,$16A09E,$17F910,$1965FE,$1AE89F,$1C823D,$1E3438,$1FFFFF,
      $21E71E, $23EB35,$260DFC
    );

  outfading : boolean = false;
  outvolume : byte = 63;
  msp : longint = 0;
  MODDATGROESSE : longint = 0;
  filter_activ : boolean = false;
  balance : byte = 12;
  Mastervolume : byte = 29;
  Startport : word = $200;
  Endport   : word = $280;
  playspeed : byte = 6;

  DETECT = 55555;
  Samfreq : word = 22;
  force_mono : boolean = false;
  force_sb : boolean = false;
  force_irq : boolean = false;
  force_dma : boolean = false;
  force_base : boolean = false;
  PC    = 0;
  AMIGA = 1;
  m669 : boolean = false;
  interrupt_gefunden : boolean = false;
  interrupt_check : boolean = false;
  Choose_lower_freq : boolean = false;
  timer_per_second  : word = 50;      { Anzahl Interrupts per Sec. }
  Sampling_Frequenz : word = 10000;     { Die Samplingfreq.; Default }
  in_retrace        : boolean = false;  { Gerade in Retracing-Proc ? }
  dsp_irq        : byte = $5;        { Interrupt des SB, Wert wird}
                                        { durch die Init-Routine     }
                                        {  ge„ndert                  }
  dma_ch            : byte = 1;         { DMA Chanel, standartm„áig  }
                                        { = 1, auf SB 16 ASP auch an-}
                                        { dere Werte m”glich ...     }
  dsp_adr           : word = $220;      { Die Base-Adress des DSP.   }
                                        { Wert wird durch die Init-  }
                                        { Routine ge„ndert           }
  SbVersMin         : BYTE = 0;         { Die Versions - Kennung     }
  SbVersMaj         : BYTE = 0;
  STEREO            : BOOLEAN = false;  { In Stereo abspielen        }
  SbRegDetected     : BOOLEAN = FALSE;  { normale SB vorhanden ?     }
  IRQDetected       : BOOLEAN = FALSE;
  SbRegInited       : BOOLEAN = FALSE;
  SbProDetected     : BOOLEAN = FALSE;  { SB Pro vorhanden ?         }
  SbProInited       : BOOLEAN = FALSE;
  Sb16Detected      : BOOLEAN = FALSE;  { SB 16 ASP vorhanden ?      }
  Sb16Inited        : BOOLEAN = FALSE;
  MixerDetected     : BOOLEAN = FALSE;  { Wenn ja, Karte >= SB Pro   }
  OldTimerInt                 = $71;    { Orginal Int-Routine des    }
                                        { verbogenen Timer - Int.    }
  Stimmen           : integer = 4;      { Anzahl der Stimmen im      }
                                        { MOD-File                   }
  Modoktave : array[1..70] of word =
   (
    1712,1616,1525,1440,1359,1283,1211, { Die Werte in Modoktave ent-}
    1143,1078,961,907,856,808,763,720,  { sprechen den im MOD-File   }
    679,641,605,571,539,509,480,453,428,{ als Tonh”hen gespeicherten }
    404,381,360,340,321,303,286,270,254,{ Werten.                    }
    240,227,214,202,191,180,170,160,151,
    143,135, 127,120,113,107,101,95,90,
    85,80,76,71,67,64,60,57,
    54,51,48,45,43,40,38,36,34,32,30);

{ PermUp_1           : byte = 0;         { Portamento Up der Stimme ? }
{ PermUp_2           : byte = 0;
 PermUp_3           : byte = 0;
 PermUp_4           : byte = 0;
 PermUp_5           : byte = 0;
 PermUp_6           : byte = 0;
 PermUp_7           : byte = 0;
 PermUp_8           : byte = 0;
 PermDo_1           : byte = 0;         { Portamento Down der Stimme }
 {PermDo_2           : byte = 0;
 PermDo_3           : byte = 0;
 PermDo_4           : byte = 0;
 PermDo_5           : byte = 0;
 PermDo_6           : byte = 0;
 PermDo_7           : byte = 0;
 PermDo_8           : byte = 0;
 PermNk1            : word = 0;
 PermNk2            : word = 0;
 PermNk3            : word = 0;
 PermNk4            : word = 0;
 PermNk5            : word = 0;
 PermNk6            : word = 0;
 PermNk7            : word = 0;
 PermNk8            : word = 0;}

 AUTO = 9999;                           { Kennung fr Auto detection }
 ON   = true;
 OFF  = false;
 playeffect : boolean = false;
 effectvolume : word = 7;
 converteff    : byte = 0;
 sensib : real = 0.9;

 dma_page : array[0..3] of byte = ($87,$83,$81,$81);
 dma_adr  : array[0..3] of byte = (0,2,4,6);
 dma_wc   : array[0..3] of byte = (1,3,5,7);

 sb16_outputlaenge : word = 0;
 letzte_ausgabe : boolean = false;

VAR
 Altintzaehler : word;
 efi : file;
 outfile : file;
{ ModPara : array[0..64] of Param_Table;}
 blockgroesse        : word;            { GrӇe des Sound-Puffers    }
 dsp_rdy_sb16        : boolean;         { Flag fr Ende der šbertrag-}
                                        { ung der Daten via DMA      }
 SbVersStr           : string[5];       { Die SB-Version als String  }
 Speed               : word;            { Abspielgeschwindigkeit     }
 oldInt              : pointer;         { Zur Sicherung des vom SB   }
                                        { zum DMA-Transfer ben”tigten}
                                        { Interrupts                 }
 irqmsk              : byte;            { zur Interruptbehandlung    }
 Vermische_proc      : pointer;         { Zeiger auf Routinen, die je}
 nmw_proc            : pointer;         { nach Anzahl der vorhandenen}
 innen_proc          : pointer;         { Stimmen ausgefhrt werden  }
 Noten_Anschlag      : array[1..8]      { Zeit seid letztem Anschlag }
                       of integer;
 Rm_Song             : Array[1..64,1..8,{ Ein Pattern                }
                         1..4] of Byte;
 rm                  : array[0..128]    { Die einzelnen Pattern      }
                       of pointer;
 Lied                : array[1..128]    { Arrangement des Liedes     }
                       of byte;
 blk                 : pointer;         { Pointer auf Daten - Puffer }
 inst        : array[1..8] of pointer;
 Samp                : Array[1..64]     { Feld mit Zeigern auf       }
                       of pointer;      { Sampels                    }
 Sam_l               : Array[1..64]     { Die L„nge der Sampels      }
                       of word;
 loop_s              : array[1..64]     { Loop-Start der Sampels     }
                       of word;
 loop_l              : array[1..64]     { Loop-L„nge der Sampels     }
                       of word;
 i1,i2,i3,i4,                           { Pointer auf aktive Sampels }
 i5,i6,i7,i8         : pt;              { in "pt"-Form               }
 inl           : array[1..8] of word;
 inp          : array[1..8] of word;
 i                   : word;
 mlj                 : word;            { Schleifenz„hler, Aktuelles }
                                        { Pattern                    }
 mli                 : word;            { Schleifenz„hler, Aktuelle  }
                                        { Zeile im Pattern           }
{ Vk1,Vk2,Vk3,                           { Vorkommawert des Faktors,  }
{ Vk4,Vkh,Vk5,                           { um den die Pos. in den Sam-}
{ Vk6,Vk7,Vk8         : word;            { pledaten erh”ht werden muá }
{ Nk1,Nk2,Nk3,                           { Vorkommawert des Faktors,  }
{ Nk4,Nkh,Nk5,                           { um den die Pos. in den Sam-}
{ Nk6,Nk7,Nk8         : byte;            { pledaten erh”ht werden muá }
{ Dif1,Dif2,Dif3,
 Dif4,Dif5,Dif6,
 Dif7,Dif8           : byte;
 Difb1,Difb2,Difb3,
 Difb4,Difb5,Difb6,
 Difb7,Difb8           : byte;}
{ Inst1vk             : word;            { Zeigt auf aktuelles Sample-}
{ Inst2vk             : word;            { byte in den Daten          }
{ Inst3vk             : word;
 Inst4vk             : word;
 Inst5vk             : word;
 Inst6vk             : word;
 Inst7vk             : word;
 Inst8vk             : word;
 Inst1nk             : byte;            { Nachkommateil des Sample-  }
{ Inst2nk             : byte;            { bytes                      }
{ Inst3nk             : byte;
 Inst4nk             : byte;
 Inst5nk             : byte;
 Inst6nk             : byte;
 Inst7nk             : byte;
 Inst8nk             : byte;}
 In_St       : array[1..8] of byte;
 sam_anz             : byte;            { Anzahl der Sampel          }
 pat_anz             : byte;            { Anzahl der Pattern         }
 m_played            : boolean;         { Musik gespielt worden ???  }
 Sound_Schleifen     : word;            { Anzahl der Durchl„ufe der  }
                                        { Misch-Prozedur             }
 Sampling_Rate       : byte;            { dem DSP bergebene Wert fr}
                                        { die Frequenz               }
 mod_name            : string;          { DOS-Name der Mod-Datei     }
 tpw                 : integer;         { Transposer - Wert          }
 loop_pos            : word;            { Laufvar., von 0 bis Speed  }
 phase_1,                               { Die zwei Phasen der Inter- }
 phase_2             : boolean;         { rupt-Mischprozedur         }
 Sampel1,Sampel2,                       { Die aktiven Sampels        }
 Sampel3,Sampel4,
 Sampel5,Sampel6,
 Sampel7,Sampel8     : pointer;
 Sagr1,Sagr2,                           { GrӇe der aktiven Sampels  }
 Sagr3,Sagr4,
 Sagr5,Sagr6,
 Sagr7,Sagr8         : word;
 mautodet            : boolean;         { Wenn TRUE werden die Speed }
                                        { Angaben im Song beachtet   }
 modmultiply         : word;            { Speed-Angabe im Song * Mod-}
                                        { multiply = Speed           }
 mloop               : boolean;         { Wenn TRUE beginnt das MOD  }
                                        { nach dem Abspielen von vorn}
 periodisch_anhalten : pointer;         { Pointer auf Stop_Prozedur  }
                                        { fr Ausgabe                }
 music_aus           : boolean;         { Wenn TRUE wird keine Musik }
                                        { gespielt ...               }
 Notvol1,Notvol2,                       { Lautst„rke der einzelnen   }
 Notvol3,Notvol4,                       { Kan„le                     }
 Notvol5,Notvol6,
 Notvol7,Notvol8     : byte;
 Pnk           : array[1..8] of byte;
 Old_TZaehler        : word;            { Zur Syncronisation des     }
                                        { alten Timerinterrupts      }
 Dma_Zaehler         : integer;         { Zum abfangen des DMA_Ready }
                                        { Interrupts                 }
 dma_abbruch         : integer;         { Abbruchwert fr Dma_Zaehler}
 mod_terminated      : boolean;         { Mod-Ausgabe beendet        }
 ls    : array[1..8] of word;
 ll     : array[1..8] of word;
 Eff  : array[1..8] of byte;
 Songname            : string[20];      { Der Name des Modfiles      }
 Instnamen           : array[1..31]     { Namen der Instrumente      }
                       of string[22];
 Inst_vol            : array[1..31]
                       of byte;
 Liedlaenge          : byte;            { L„nge des Liedes           }
 Seczaehler          : word;            { zur Zeitermittlung         }
 Laufsec,Laufmin     : byte;            { Laufzeit des Liedes        }
 Pattgroesse : integer;  { Die dem Modtyp entspr. PatterngrӇe }
 XMSMaxFree          : word;            { Max. freier XMS-Speicher   }
 MinXms              : word;            { Wenn XMSMaxFree < MinXms   }
 xmsHandles             : array[1..32]
                       of word;         { Handles fr XMS            }

 soundeff : pointer;
 effektgroesse : word;
 effektposi : word;
 Effvk      : word;
 Effnk      : byte;
 Effistvk   : word;
 Effistnk   : byte;
 Effekt : pt;
 Effekt_loeschen : boolean;
 tonhoehenwert : byte;

{ tempolist : array[1..128] of byte;
 breaklist : array[1..128] of byte;}
 ziel : pt;                             { Abspielpuffer im pt-Format }
 Modp  : pointer;                       { Pointer auf Rm_Song        }
 note1,note2,                           { Aktives Instument der      }
 note3,note4,                           { Stimme                     }
 note5,note6,
 note7,note8 :byte;

 Fadepos1,fadepos2,
 fadepos3,fadepos4,
 fadepos5,fadepos6,
 fadepos7,fadepos8 : word;

 intback : pointer;
 port21 : byte;

 vocf : file;
 fgr : longint;
 blk1,blk2 : pointer;
 voch : vocheader;
 vblock : voiceblock;
 intpointer : pointer;
 dsp_rdy_voc : boolean;
 blockgr : word;
 PLAYING_MOD : boolean;
 PLAYING_VOC : boolean;
 dummarray : array[1..20] of byte;
 lastone : boolean;
 VOC_READY : boolean;
 inread : array[1..25] of byte;
 vocsstereo : boolean;
 Mod_zu_ende : boolean;

implementation

begin;
end.



unit design;

interface
uses crt,windos;

procedure writexy(x,y : integer;s : string);
procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
function wrhexb(b : byte) : string;
function wrhexw(w : word) : string;
procedure save_screen;
procedure restore_screen;
Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
procedure cursor_On;
procedure cursor_Off;

implementation

var filenames : array[1..512] of string[12];
const      Screen_Akt   : byte = 1;

procedure writexy(x,y : integer;s : string);
begin;
 gotoxy(x,y);
 write(s);
end;

procedure save_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt <= 4 then begin;
    inc(Screen_Akt);
    move(screen[1],screen[Screen_Akt],8000);
  end;
end;

procedure restore_screen;
var Screen : array[1..4,1..8000] of byte absolute $b800:0000;
begin;
  if Screen_Akt >= 2 then begin;
    move(screen[Screen_Akt],screen[1],8000);
    dec(Screen_Akt);
  end;
end;

procedure rahmen(rt: byte;startx,starty,dx,dy : integer);
const frames : array[1..2,1..6] of char =
 (('Ú','¿','Ù','À','Ä','³'),
  ('É','»','¼','È','Í','º'));
var lx,ly : integer;
    s : string;
begin;
  { obere Zeile }
  s := frames[rt,1];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,2];
  gotoxy(startx,starty);
  write(s);
  { mittleren Zeilen }
  for ly := 1 to dy-2 do begin;
    s := frames[rt,6];
    for lx := 1 to dx-2 do s := s + ' ';
    s := s + frames[rt,6];
    gotoxy(startx,starty+ly);
    write(s);
  end;
  { untere Zeile }
  s := frames[rt,4];
  for lx := 1 to dx-2 do s := s + frames[rt,5];
  s := s + frames[rt,3];
  gotoxy(startx,starty+dy-1);
  write(s);
end;

Procedure Fenster(x,y,dx,dy : integer; s : string;rcol,bcol : byte);
var tlaeng : byte;
    deltx,tstartpos : byte;
begin;
  tlaeng := length(s);
  tstartpos := x + ((dx-Tlaeng) SHR 1);
  textcolor(rcol);
  textbackground(bcol);
  rahmen(1,x,y,dx,dy);
  writexy(tstartpos,y,s);
end;

procedure sort_filenames(start,ende : integer);
{
 Hier sollte fr gr”áere Verzeichnise Quick-Sort eingebaut werden !
}
var hilfe : string;
    l1,l2 : integer;
begin;
  for l1 := start to ende-1 do begin;
    for l2 := start to ende-1 do begin;
      if filenames[l2] > filenames[l2+1] then begin;
        hilfe := filenames[l2];
        filenames[l2] := filenames[l2+1];
        filenames[l2+1] := hilfe;
      end;
    end;
  end;
end;

function select_datei(dir : string;mask : pchar;mtext,comment: string) : string;
const  zeile : byte = 1;
  spalte : byte = 0;
  Start_fndisp : word = 0;
var
  DirInfo: TSearchRec;
  count : integer;
  Nullpos : byte;
var li,lj : integer;
    inp : char;
    retval : string;
    kasten_gefunden : boolean;
    select : byte;
    changed : boolean;
    End_fndisp : word;
begin
  {$I+}
  for li := 1 to 512 do filenames[li] := ' - - -';
  count := 1;
  FindFirst(mask, faArchive, DirInfo);
  while DosError = 0 do
  begin
    filenames[count] := (DirInfo.Name);
    Nullpos := pos(#0,filenames[count]);
    if Nullpos <> 0 then
      filenames[count] := copy(filenames[count],0,Nullpos-1);
    inc(count);
    FindNext(DirInfo);
  end;
  {$I-}

  sort_filenames(1,count-1);
  save_screen;
  Fenster(5,4,72,16,comment,black,7);
  textcolor(1);
  writexy(21,5,'         Bitte Datei ausw„hlen');
  textcolor(black);
  inp := #255;
  changed := true;
  repeat
    textcolor(black);
    if changed then begin;
      changed := false;
      for lj := 0 to 4 do begin;
        for li := 1 to 12 do begin;
          writexy(7+lj*14,5+li,'            ');
          writexy(7+lj*14,5+li,filenames[lj*12+li+Start_fndisp]);
        end;
      end;
      textcolor(14);
      writexy(7+Spalte*14,5+Zeile,filenames[Spalte*12+Zeile+Start_fndisp]);
    end;
    if keypressed then inp := readkey;
    if ord(inp) = 0 then inp := readkey;
    case ord(inp) of
      32,
      13: begin;
            inp := #13;
            changed := true;
            if (pos('- - -',filenames[Spalte*12+Zeile+Start_fndisp]) = 0) then
              retval := filenames[Spalte*12+Zeile+Start_fndisp]
            else
              retval := 'xxxx';
          end;
      27: begin;
            inp := #27;
            changed := true;
            retval := 'xxxx';
          end;
      71: begin; { Pos 1 }
            inp := #255;
            Zeile  := 1;
            Spalte := 0;
            changed := true;
          end;
      72: begin; { Pfeil up }
            inp := #255;
            changed := true;
            if not ((Zeile = 1) and (Spalte = 0)) then
              dec(Zeile);
            if Zeile = 0 then begin;
              dec(Spalte);
              Zeile := 12;
            end;
          end;
      73: begin; { Page UP }
            if Start_fndisp >= 12 then
              dec(Start_fndisp,12)
            else begin;
              Start_fndisp := 0;
              Zeile := 1;
            end;
            inp := #255;
            changed := true;
          end;
      81: begin; { Page Down }
            if ((Spalte+1)*12+Start_fndisp < count) and
            (Start_fndisp < 500) then
              inc(Start_fndisp,12)
            else
              Start_fndisp := count-11;
            inp := #255;
            changed := true;
          end;
      75: begin; { Pfeil links }
            inp := #255;
            changed := true;
            if Spalte = 0 then begin;
              if Start_fndisp >= 12 then dec(Start_fndisp,12);
            end else begin;
              if Spalte > 0 then dec(Spalte);
            end;
          end;
      77: begin; { Pfeil rechts }
            inp := #255;
            changed := true;
            if Spalte = 4 then begin;
              if ((Spalte+1)*12+Start_fndisp < count) and
              (Start_fndisp < 500) then inc(Start_fndisp,12);
            end else begin;
            if (Spalte < 4) and
              (Zeile+(Spalte+1)*12+Start_fndisp < count) then
                inc(Spalte);
            end;
          end;
      79: begin; { End }
            inp := #255;
            changed := true;
            Spalte := (count-Start_fndisp-12) div 12;
            Zeile := (count-Start_fndisp) - Spalte*12 -1;
          end;
      80: begin; { Pfeil down }
            inp := #255;
            changed := true;
            if ((Zeile = 12) and (Spalte = 4)) then begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then begin;
                inc(Start_fndisp,1);
              end;
            end else begin;
              if (Start_fndisp+Zeile+Spalte*12 < count-1) then
                inc(Zeile);
             end;
            if Zeile > 12 then begin;
              inc(Spalte);
              Zeile := 1;
            end;
          end;
      82 : begin;
            changed := true;
             save_screen;
             textcolor(black);
             rahmen(2,16,9,45,5);
             writexy(20,10,' Dateinamen eingeben ('+mtext+')');
             writexy(20,12,'Name: ');
             readln(retval);
             if retval = '' then retval := 'xxxx';
             restore_screen;
           end;
     end;
  until (inp = #13) or (inp = #27) or (inp = #32)
     or (inp = #82);
  restore_screen;
  textbackground(black);
  textcolor(7);
  select_datei := retval;
end;

function wrhexb(b : byte) : string;
const hexcar : array[0..15] of char =
 ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F');
begin;
  wrhexb := hexcar[(b shr 4)] + hexcar[(b AND $0F)];
end;

function wrhexw(w : word) : string;
begin;
  wrhexw := '$'+wrhexb(hi(w))+wrhexb(lo(w));
end;

procedure cursor_Off; assembler;
asm
  xor ax,ax
  mov ah,01h
  mov cx,2020h
  int 10h
end;

procedure cursor_on; assembler;
asm
 mov ah,01h
 mov cx,0607h
 int 10h
end;



begin;
end.uses crt,dos,vocplay,design;

var ch : char;
    next_voc : integer;
    Vocname : string;

procedure Write_Helptext;
begin;
  textcolor(lightgray);
  textbackground(black);
  clrscr;
  writeln(' DATA BECKER VOC-Player      Version 1.0, (c) 1994',
	        '      Autor: Boris Bertelsons');
  writeln;
  writeln(' Usage: Vocdemo <Filename[.VOC]> [optionen]');
  writeln;
  writeln(' Optionen sind:');
	writeln(' -H        : Dieser Screen');
  writeln(' -In       : Benutze den Interrupt n');
	writeln(' -Dn       : Benutze den DMA-Kanal n');
  writeln(' -Pxxx     : Benutze die Baseadresse xxx');
  writeln;
  Cursor_On;
  halt(0);
end;

procedure interprete_commandline;
var cs,hs : string;
    li,code : integer;
    Datnm : boolean;
begin;
  for li := 1 to 10 do begin;
    cs := paramstr(li);
    Datnm := true;
    { Hilfe Angefordert ? }
    if (pos('-h',cs) <> 0) or (pos('/h',cs) <> 0) or
       (pos('-H',cs) <> 0) or (pos('/H',cs) <> 0) or
       (pos('-?',cs) <> 0) or (pos('/?',cs) <> 0) then begin;
       write_Helptext;
      Datnm := false;
    end;
    { force irq }
    if (pos('-i',cs) <> 0) or (pos('/i',cs) <> 0) or
       (pos('-I',cs) <> 0) or (pos('/I',cs) <> 0) then begin;
      force_irq := true;
      hs := copy(cs,3,length(cs)-2);
      val(hs,dsp_irq,code);
      Datnm := false;
    end;
    { Force DMA ? }
    if (pos('-d',cs) <> 0) or (pos('/d',cs) <> 0) or
       (pos('-D',cs) <> 0) or (pos('/D',cs) <> 0) then begin;
      force_dma := true;
      hs := copy(cs,3,length(cs)-2);
      val(hs,dma_ch,code);
      Datnm := false;
    end;
    { Force Base ? }
    if (pos('-p',cs) <> 0) or (pos('/p',cs) <> 0) or
       (pos('-P',cs) <> 0) or (pos('/P',cs) <> 0) then begin;
       hs := copy(cs,3,length(cs)-2);
       if hs = '200' then dsp_adr := $200;
       if hs = '210' then dsp_adr := $210;
       if hs = '220' then dsp_adr := $220;
       if hs = '230' then dsp_adr := $230;
       if hs = '240' then dsp_adr := $240;
       if hs = '250' then dsp_adr := $250;
       if hs = '260' then dsp_adr := $260;
       if hs = '270' then dsp_adr := $270;
       if hs = '280' then dsp_adr := $280;
       Startport := dsp_adr;
       Endport   := dsp_adr;
      Datnm := false;
    end;
    if Datnm then begin;
      Vocname := cs;
    end;
  end;
end;

procedure Spiele_Vocdatei(datname : string);
var li : integer;
    ch : char;
    loopcounter : word;
begin;
  loopcounter := 0;
  repeat
    inc(loopcounter);
    clrscr;
    writexy(10,08,'Achtung !  Das VOC wird gnadenlos geloopt !!!');
    writexy(10,10,'Beenden mit der Taste   >>  Q  <<');
    writexy(10,14,'M”glichst den Smartdrv entfernen, weil laaaaaaangsam !');
    gotoxy(10,17);
    write('Durchlauf Nr. ',loopcounter);
    Init_Voc(datname);
    ch := #0;
    repeat
      if keypressed then ch := readkey;
    until VOC_READY or (upcase(ch) = 'Q');
    VOC_DONE;
  until upcase(ch) = 'Q';
end;


begin;
 cursor_off;
 interprete_commandline;
 Init_SB;
 textcolor(lightgray);
 textbackground(black);
 write_sbconfig;
 delay(1333);
 repeat
   textcolor(15);
   textbackground(1);
   clrscr;
   Vocname := select_datei('*.voc','*.voc','','');
   if Vocname = 'xxxx' then next_voc := 255
   else Spiele_Vocdatei(Vocname);
 until next_voc = 255;
 cursor_on;
 textmode(3);
end.
unit vocplay;

interface uses crt,dos;

TYPE vocheader = record
       Kennstr : array[0..19] of char;
       Sampoff : word;
       Verslo  : Byte;
       Vershi  : Byte;
       Kennung : word;
     end;

     Voiceblock = record
       Kennung  : byte;
       Laeng_lo : word;
       Laeng_hi : byte;
       SR       : byte;
       Pack     : byte;
     end;

const
  { Soundblaster - Konstanten }
  Startport          : word = $200;
  Endport            : word = $280;
  force_irq          : boolean = false;
  force_dma          : boolean = false;
  force_base         : boolean = false;
  dsp_irq            : byte = $5;        { Interrupt des SB, Wert wird}
                                        { durch die Init-Routine     }
                                        {  ge„ndert                  }
  dma_ch             : byte = 1;         { DMA Chanel, standartm„áig  }
                                        { = 1, auf SB 16 ASP auch an-}
                                        { dere Werte m”glich ...     }
  dsp_adr            : word = $220;      { Die Base-Adress des DSP.   }
                                        { Wert wird durch die Init-  }
                                        { Routine ge„ndert           }
  SbVersMin          : BYTE = 0;         { Die Versions - Kennung     }
  SbVersMaj          : BYTE = 0;
  STEREO             : BOOLEAN = false;  { In Stereo abspielen        }
  SbRegDetected      : BOOLEAN = FALSE;  { normale SB vorhanden ?     }
  IRQDetected        : BOOLEAN = FALSE;
  SbRegInited        : BOOLEAN = FALSE;
  SbProDetected      : BOOLEAN = FALSE;  { SB Pro vorhanden ?         }
  SbProInited        : BOOLEAN = FALSE;
  Sb16Detected       : BOOLEAN = FALSE;  { SB 16 ASP vorhanden ?      }
  Sb16Inited         : BOOLEAN = FALSE;
  MixerDetected      : BOOLEAN = FALSE;  { Wenn ja, Karte >= SB Pro   }

  { Voc - Constanten }
  block_activ        : byte = 1;


  { Soundblaster - Variablen }
var dsp_rdy_voc      : boolean;
    blockgr          : word;
    Transfer_Testing : boolean;
    SaveExitProc     : Pointer;             { N”tig, da eigene Exitproc  }

var lastone          : boolean;
    VOC_READY        : boolean;
    inread           : array[1..25] of byte;
    vocsstereo       : boolean;
    vocf             : file;
    fgr              : longint;
    blk1,blk2        : pointer;
    voch             : vocheader;
    vblock           : voiceblock;


 function init_sb : boolean;
 {
  Die Function init_sb initialisiert die Soundblaster-Karte. Sie
  erkennt automatisch Base-Adress und IRQ, prft, um welche Sound-
  blasterversion es sich handelt und setzt entsprechende globale
  Variablen, die z.B. mittels write_sbConfig ausgegeben werden k”nnen.
  Die Funktion liefert True, wenn eine SB initialisiert werden konnte.
 }

 procedure write_sbConfig;
 {
  Gibt die gefundene Konfiguration aus (Textmodus !). Alternativ:
  Direkter Zugriff auf die entsprechenden Variablen.
 }

 procedure Wr_dsp(v : byte);
 {
  Schreibt den bergebenen Wert in das Soundblaster-Register
 }

 FUNCTION Reset_sbCard : BOOLEAN;
 {
  Resettet die SB-Karte. Liefert TURE, wenn erfolgreich
 }

 procedure Set_Timeconst_sb16(tc : byte);
 {
  Setzt die Timer-Konstante die nach der Formel
  tc := 256-(1.000.000 / Frequenz) berechnet wird
 }

 procedure Spiele_Block_Dsp(gr : word;bk : pointer;b1,b2 : boolean);
 {
  Spielt den ber blk adressierten Block via DMA ab. Initialisiert die
  ben”tigten Variablen und ruft dann eine der drei SPIELE_SB-Proceduren
  auf.
 }

 procedure Spiele_Sb(Segm,Offs,dsize : word);
 {
  Spielt den adressierten Block ber DMA ab. Fr SB / SB Pro
 }

 procedure Spiele_SbPro(Segm,Offs,dsize : word);
 {
  Spielt den adressierten Block ber DMA ab. Fr SB Pro
 }

 procedure Spiele_Sb16(Segm,Offs,dsize : word);
 {
  Spielt den adressierten Block ber DMA ab. Fr SB 16
 }


 procedure Filter_Ein;
 {
  Schaltet den XBass-Filter ein
 }

 procedure Filter_MID;
 {
  Schaltet den Filter auf Normalbetrieb
 }
 procedure Filter_Aus;
 {
  Schaltet den Filter auf H”hen-Hervorhebung
 }

 procedure Set_Balance(Wert : byte);
 {
  Die Procedure Setzt die Balance entsprechend dem bergebenen Wert.
  Dabei steht 0 fr ganz links, 12 fr Mitte und 24 fr ganz rechts
 }

 procedure Set_Volume(Wert : byte);
 {
  Die Procedure setzt die Lautst„rke fr die generelle (!) Ausgabe
  (Master Volume). Erlaubte Werte liegen zwischen 0 und 31
 }


 Procedure Init_Voc(filename : string);
 {
  Die Procedure startet die Ausgabe des in filename bergebenen
  VOC-Files
 }

 procedure voc_done;
 {
  Mit der Procedure VOC_DONE halten Sie die Ausgabe eines VOC-Files an.
  Diese Procedure muá auch aufgerufen werden, wenn die Ausgabe des
  VOC-Files schon am Ende angelangt ist.
 }


implementation

TYPE
  pt = record                           { erm”glicht die einfache    }
    ofs,sgm  :  word;                   { Behandlung von Pointern    }
  end;

CONST
  filter_activ       : boolean = false;
  balance            : byte = 12;
  Mastervolume       : byte = 29;
  Samfreq            : word = 22;
  PC    = 0;
  AMIGA = 1;
  interrupt_gefunden : boolean = false;
  interrupt_check    : boolean = false;
  timer_per_second   : word = 1000;      { Anzahl Interrupts per Sec. }
  Sampling_Frequenz  : word = 10000;     { Die Samplingfreq.; Default }
  dma_page           : array[0..3] of byte = ($87,$83,$81,$81);
  dma_adr            : array[0..3] of byte = (0,2,4,6);
  dma_wc             : array[0..3] of byte = (1,3,5,7);

  sb16_outputlaenge  : word = 0;
  letzte_ausgabe     : boolean = false;

VAR
 blockgroesse        : word;            { GrӇe des Sound-Puffers    }
 dsp_rdy_sb16        : boolean;         { Flag fr Ende der šbertrag-}
                                        { ung der Daten via DMA      }
 SbVersStr           : string[5];       { Die SB-Version als String  }
 oldInt              : pointer;         { Zur Sicherung des vom SB   }
                                        { zum DMA-Transfer ben”tigten}
                                        { Interrupts                 }
 irqmsk              : byte;            { zur Interruptbehandlung    }
 blk                 : pointer;         { Pointer auf Daten - Puffer }
 Sampling_Rate       : byte;            { dem DSP bergebene Wert fr}
                                        { die Frequenz               }
 intback             : pointer;
 port21              : byte;


FUNCTION Detect_Mixer_sb16 : boolean; forward;


{
 ***************************************************************************

             S O U N D B L A S T E R   -   P R O C E D U R E N

 ***************************************************************************
}


procedure Wr_dsp(v : byte);
{
 Wartet, bis der DSP zum Schreiben bereit ist, und schreibt dann das
 in "v" bergebene Byte in den DSP
}
begin;
  while port[dsp_adr+$c] >= 128 do ;
  port[dsp_adr+$c] := v;
end;

FUNCTION SbReadByte : BYTE;
{
 Die Function wartet, bis der DSP gelesen werden kann und liefert den
 gelesenen Wert zurck
}
begin;
  while port[dsp_adr+$a] = $AA do ;     { warten, bis DSP ready      }
  SbReadByte := port[dsp_adr+$a];       { Wert schreiben             }
end;

procedure SBreset;
VAR bt,ct, stat : BYTE;
begin;
  PORT[dsp_adr+$6] := 1;                { dsp_adr+$6 = Resettfunktion}
  FOR ct := 1 TO 100 DO;
  PORT[dsp_adr+$6] := 0;
  bt := 0;
  repeat
    ct := 0;
    repeat
      stat := port[dsp_adr + $E];
    until (ct > 8000) or (stat >= 128);
    inc(bt);
  until (bt > 100) or (port[dsp_adr + $A] = $AA);
end;

FUNCTION Reset_SBCard : BOOLEAN;
{
 Die Function resetet den DSP. War das Resetten erfolgreich, wird
 TRUE zurckgeliefert, ansonsten FALSE
}
CONST  ready = $AA;
VAR ct, stat : BYTE;
BEGIN
  PORT[dsp_adr+$6] := 1;                { dsp_adr+$6 = Resettfunktion}
  FOR ct := 1 TO 100 DO;
  PORT[dsp_adr+$6] := 0;
  stat := 0;
  ct   := 0;                            { Der Vergleich ct < 100, da }
  WHILE (stat <> ready)                 { die Initialisierung ca.    }
  AND   (ct < 100)      DO BEGIN        { 100ms dauert               }
    stat := PORT[dsp_adr+$E];
    stat := PORT[dsp_adr+$a];
    INC(ct);
  END;
  Reset_SBCard := (stat = ready);
END;

FUNCTION Detect_SBReg : BOOLEAN;
{
 Die Funktion liefert TRUE zurck, wenn ein Soundblaster initialisiert
 werden konnte, ansonsten FALSE. Die Variable dsp_adr wird auf die
 Base-Adresse des SB gesetzt.
}
VAR
  Port, Lst : WORD;
BEGIN
 Detect_SBReg := SbRegDetected;
 IF SbRegDetected THEN EXIT;            { Exit, wenn initialisiert   }
 Port := Startport;                     { M”gliche SB-Adressen zwi-  }
 Lst  := Endport;                       { schen $210 und $280 !      }
 WHILE (NOT SbRegDetected)
 AND   (Port <= Lst)  DO BEGIN
   dsp_adr := Port;
   SbRegDetected := Reset_SBCard;
   IF NOT SbRegDetected THEN
     INC(Port, $10);
 END;
 Detect_SBReg := SbRegDetected;
END;

PROCEDURE SbGetDSPVersion;
{
 Ermittelt die Version des DSP und speichert das Ergebnis in den globalen
 Variablen SBVERSMAJ und SBVERSMIN sowie SBVERSSTR ab.
}
VAR i : WORD;
    t : WORD;
    s : STRING[2];
BEGIN
  Wr_dsp($E1);                     { $E1 = Versionsabfrage      }
  SbVersMaj := SbReadByte;
  SbVersMin := SbReadByte;
  str(SbVersMaj, SbVersStr);
  SbVersStr := SbVersStr + '.';
  str(SbVersMin, s);
  if SbVersMin > 9 then
    SbVersStr := SbVersStr +       s
  else
    SbVersStr := SbVersStr + '0' + s;
END;

function wrt_dsp_adr_sb16 : string;
{
 Liefert die Base-Adresse des SB als String zurck
}
begin;
  case dsp_adr of
    $210 : wrt_dsp_adr_sb16 := '210';
    $220 : wrt_dsp_adr_sb16 := '220';
    $230 : wrt_dsp_adr_sb16 := '230';
    $240 : wrt_dsp_adr_sb16 := '240';
    $250 : wrt_dsp_adr_sb16 := '250';
    $260 : wrt_dsp_adr_sb16 := '260';
    $270 : wrt_dsp_adr_sb16 := '270';
    $270 : wrt_dsp_adr_sb16 := '280';
   END;
end;

function wrt_dsp_irq : string;
{
 Liefert den IRQ des SB als String zurck
}
begin;
  case dsp_irq of
     $2 : wrt_dsp_irq := '2 h';
     $3 : wrt_dsp_irq := '3 h';
     $5 : wrt_dsp_irq := '5 h';
     $7 : wrt_dsp_irq := '7 h';
    $10 : wrt_dsp_irq := '10 h';
   END;
end;

procedure Set_Timeconst_sb16(tc : byte);
{
 Procedure zum setzen der Time-Konstanten. Sie berechnet sich nach der
 Formel  tc := 256 - (1000000 / Frequenz).
}
begin;
  Wr_dsp($40);                     { $40 = Setze Sample Rate    }
  Wr_dsp(tc);
end;

procedure test_uebertragung;
{
 Zur Interrupt - Detection
}
begin;
   getmem(blk,3000);
   fillchar(blk^,3000,127);
   blockgroesse := 2000;
   letzte_ausgabe := true;
   Sampling_Rate := 211;
   Spiele_Block_Dsp(blockgroesse,blk,true,false);
   delay(100);
   freemem(blk,3000);
end;

procedure write_sbConfig;
{
 Die Procedure gibt die gefundene Konfiguration auf dem Bildschirm
 aus. Sie dient vornehmlich als Beispiel, wie die Informationen
 verwendet werden k”nnen
}
begin;
  clrscr;
  if SbRegDetected then begin;
    writeln('Soundkarte an Base ',wrt_dsp_adr_sb16,'h mit IRQ ',
    wrt_dsp_irq,' gefunden.');
  end else begin;
    writeln('Keine Soundblaster-kompatibele Karte gefunden !');
  end;
  if MixerDetected then begin;
    writeln('Mixer - Chip gefunden');
    if SbVersMaj < 4 then
      writeln('Die gefundene Karte ist',
			' ein Soundblaster Pro oder kompatibel')
    else
      writeln('Die gefundene Karte ist',
      ' ein Soundblaster 16 ASP oder kompatibel');
  end else begin;
    writeln('Die gefundene Karte ist',
    ' ein Soundblaster oder kompatibel');
  end;
  writeln('Die Versionsnummer lautet ',SbVersStr);
end;

procedure Exit_Sb16;
{
 Diese Prozedur wir beim Beenden des Programms aufgerufen und setzt
 den verbogenen DMA-Interrupt auf seinen Ausgangswert
}
begin;
  setintvec($8+dsp_irq,oldint);         { Alten Interrupt wieder her-}
  port[$21] := Port[$21] or irqmsk;     { stellen und Maskierung auf }
  port[dsp_adr+$c] := $d3;              { alten Wert zurck          }
  Port[$20] := $20;
  Wr_dsp($D0);
end;

procedure Spiele_Sb16(Segm,Offs,dsize : word);
{
 Diese Procedure spielt den ber Segm:Offs adressierten Block mit der
 GrӇe dsize ab. Es ist darauf zu achten, das der DMA-Controller NICHT
 Seitenbergreifend arbeiten kann ...
}
var li : word;
begin;
  port[$0A] := dma_ch+4;                { DMA-Kanal sperren          }
  Port[$0c] := 0;                       { Adresse des Puffers (blk)  }
  Port[$0B] := $49;                     { fr Soundausgabe           }
  Port[dma_adr[dma_ch]] := Lo(offs);    { an DMA-Controller          }
  Port[dma_adr[dma_ch]] := Hi(offs);
  Port[dma_wc[dma_ch]] := Lo(dsize-1);  { GrӇe des Blockes (block-  }
  Port[dma_wc[dma_ch]] := Hi(dsize-1);  { groesse) an DMA-Controller }
  Port[dma_page[dma_ch]] := Segm;
  if sb16_outputlaenge <> dsize then begin;
    Wr_dsp($C6);                   { DSP-Befehl 8-Bit ber DMA  }
    if stereo then                      { fr SB16 Nur zum Starten ! }
      Wr_dsp($20)
    else
      Wr_dsp($00);
    Wr_dsp(Lo(dsize-1));           { GrӇe des Blockes an       }
    Wr_dsp(Hi(dsize-1));           { den DSP                    }
    sb16_outputlaenge := dsize;
  end else begin;
    Wr_dsp($45);                   { DMA Continue SB16 8-Bit    }
  end;
  Port[$0A] := dma_ch;                  { DMA-Kanal freigeben        }
end;

procedure Spiele_SbPro(Segm,Offs,dsize : word);
{
 Diese Procedure spielt den ber Segm:Offs adressierten Block mit der
 GrӇe dsize ab. Es ist darauf zu achten, das der DMA-Controller NICHT
 Seitenbergreifend arbeiten kann ...
}
var li : word;
begin;
  port[$0A] := dma_ch+4;                { DMA-Kanal sperren          }
  Port[$0c] := 0;                       { Adresse des Puffers (blk)  }
  Port[$0B] := $49;                     { fr Soundausgabe           }
  Port[dma_adr[dma_ch]] := Lo(offs);    { an DMA-Controller          }
  Port[dma_adr[dma_ch]] := Hi(offs);
  Port[dma_wc[dma_ch]] := Lo(dsize-1);  { GrӇe des Blockes (block-  }
  Port[dma_wc[dma_ch]] := Hi(dsize-1);  { groesse) an DMA-Controller }
  Port[dma_page[dma_ch]] := Segm;

  Wr_dsp($48);
  Wr_dsp(Lo(dsize-1));             { GrӇe des Blockes an       }
  Wr_dsp(Hi(dsize-1));             { den DSP                    }
  Wr_dsp($91);
  Port[$0A] := dma_ch;                  { DMA-Kanal freigeben        }
end;

procedure Spiele_Sb(Segm,Offs,dsize : word);
{
 Diese Procedure spielt den ber Segm:Offs adressierten Block mit der
 GrӇe dsize ab. Es ist darauf zu achten, das der DMA-Controller NICHT
 Seitenbergreifend arbeiten kann ...
}
var li : word;
begin;
  port[$0A] := dma_ch+4;                { DMA-Kanal sperren          }
  Port[$0c] := 0;                       { Adresse des Puffers (blk)  }
  Port[$0B] := $49;                     { fr Soundausgabe           }
  Port[dma_adr[dma_ch]] := Lo(offs);    { an DMA-Controller          }
  Port[dma_adr[dma_ch]] := Hi(offs);
  Port[dma_wc[dma_ch]] := Lo(dsize-1);  { GrӇe des Blockes (block-  }
  Port[dma_wc[dma_ch]] := Hi(dsize-1);  { groesse) an DMA-Controller }
  Port[dma_page[dma_ch]] := Segm;
  Wr_dsp($14);
  Wr_dsp(Lo(dsize-1));                  { GrӇe des Blockes an       }
  Wr_dsp(Hi(dsize-1));                  { den DSP                    }
  Port[$0A] := dma_ch;                  { DMA-Kanal freigeben        }
end;

procedure Spiele_Block_Dsp(gr : word;bk : pointer;b1,b2 : boolean);
{
 Diese Procedure startet die Ausgabe des Daten-Blocks blk mit der
 Gr”áe blockgroesse ber DMA
}
var l : longint;
    pn,offs : word;
    hbyte : byte;
    a : word;
    OldV,NewV,Hilfe : byte;
    stereoreg : byte;
    sr : word;
    samps : byte;
begin;
  Transfer_Testing := b1;

  dsp_rdy_sb16 := false;
  l := 16*longint(pt(bk).sgm)+pt(bk).ofs;
  pn := pt(l).sgm;
  offs := pt(l).ofs;

  if Transfer_Testing then begin;
    set_timeconst_sb16(Sampling_Rate);
    if sb16Detected then begin;
      if stereo then
        Spiele_Sb16(pn,offs,gr*2)
      else
        Spiele_Sb16(pn,offs,gr);
    end else begin;
      if stereo then begin;
        SR := word(-1000000 DIV (Sampling_Rate-256));
        SR := SR * 2;
        Samps := 256 - (1000000 DIV SR);
        set_timeconst_sb16(Samps);
        Spiele_SbPro(pn,offs,gr*2);
      end else
        Spiele_Sb(pn,offs,gr);
    end;
  end else begin;
    sb16_outputlaenge := 0;
    set_timeconst_sb16(vblock.SR);
    if sb16Detected then begin;
      if stereo then begin;
        Spiele_Sb16(pn,offs,gr);
      end else begin;
        Spiele_Sb16(pn,offs,gr);
      end;
    end else begin;
      if stereo then begin;
        Spiele_SbPro(pn,offs,gr);
      end else begin;
        Spiele_Sb(pn,offs,gr);
      end;
    end;
  end;
end;

procedure dsp_int_sb16; interrupt;
{
 Diese Procedure wird durch den Interrupt angesprungen, der am Ende
 einer Blockbertragung generiert wird. Wenn nicht das Flag
 letzte_ausgabe gesetzt ist, wird eine neue Ausgabe gestartet
}
var h : byte;
begin;
  if interrupt_check then begin;
    IRQDetected := true;
  end else begin;
    if Transfer_Testing then begin;
      h := port[dsp_adr+$E];
      dsp_rdy_sb16 := true;

      if not letzte_ausgabe then begin;
        Spiele_Block_Dsp(blockgroesse,blk,true,false);
      end;
    end else begin;
      h := port[dsp_adr+$E];
      if (fgr > blockgr) and not lastone then begin
        lastone := false;
        if block_activ = 1 then begin
          Spiele_Block_Dsp(blockgr,blk2,false,true);
          blockread(vocf,blk1^,blockgr);
          fgr := fgr - blockgr;
          block_activ := 2;
        end else begin;
          Spiele_Block_Dsp(blockgr,blk1,false,true);
          blockread(vocf,blk2^,blockgr);
          fgr := fgr - blockgr;
          block_activ := 1;
        end;
      end else begin;
        if not lastone then begin;
          if block_activ = 1 then begin
            Spiele_Block_Dsp(blockgr,blk2,false,true);
            lastone := true;
          end else begin;
            Spiele_Block_Dsp(blockgr,blk1,false,true);
            lastone := true;
          end;
        end else begin;
          dsp_rdy_sb16 := true;
          Wr_dsp($D0);
          VOC_READY := true;
        end;
      end;
    end;
  end;
  Port[$20] := $20;
end;

procedure detect_sbIRQ;
{
 Diese Routine erkennt den IRQ der Soundblaster-Karte. Es werden dazu
 alle m”glichen Interrupts durchgetestet. Dazu werden kurze Blocke
 via DMA ausgegeben. Wenn am Ende der Ausgabe der eingestellte Inter-
 rupt angesprungen wird, so ist der richtige gefunden
}
const moegliche_irqs : array[1..5] of byte = ($2,$3,$5,$7,$10);
var i : integer;
    h : byte;
begin;
 getintvec($8+dsp_irq,intback);         { Werte sichern !            }
 port21 := port[$21];
 getmem(blk,1200);
 fillchar(blk^,1200,127);
 set_Timeconst_sb16(211);
 Wr_dsp($D3);                           { Lautsprecher aus           }
 i := 1;
 interrupt_check := true;
 while (i <= 5) and (not IRQDetected) do
   begin;
     dsp_irq := moegliche_irqs[i];      { zu Testender IRQ           }
     getintvec($8+dsp_irq,oldint);      { Interrupt Verbiegen        }
     setintvec($8+dsp_irq,@Dsp_Int_sb16);
     irqmsk := 1 shl dsp_irq;
     port[$21] := port[$21] and not irqmsk;
     Sampling_Rate := 211;
     blockgroesse := 1200;              { testweise Ausgabe          }
     Spiele_Block_Dsp(blockgroesse,blk,true,false);
     delay(150);
     setintvec($8+dsp_irq,oldint);      { Interrupt wieder zurck    }
     port[$21] := Port[$21] or irqmsk;
     h := port[dsp_adr+$E];
     Port[$20] := $20;
     inc(i);
   end;
 interrupt_check := false;
 Wr_dsp($D1);                           { Lautsprecher wieder ein    }
 freemem(blk,1200);
 setintvec($8+dsp_irq,intback);         { Alte Werte zurck !!!      }
 port[$21] := port21;
 dsp_rdy_sb16 := true;
end;

function Init_SB : boolean;
{
 Diese Function initialisiert den Soundblaster. Sie liefert TRUE
 zurck, wenn die Initialisierung erfolgreich war, ansonsten FALSE.
 Der Lautsprecher fr Sampling-Ausgabe wird eingeschaltet. Der
 DMA-Ready Interrupt wird auf eine eigene Routine verbogen.
}
begin;
  if not Detect_SBReg then begin;
    Init_SB := false;
    exit;
  end;
{ Soundblaster gefunden      }
 if not force_irq then detect_sbIRQ;    { IRQ auto-detection         }
   test_uebertragung;
 if not force_irq then detect_sbIRQ;    { 2. Test fr SB n”tig !     }
 if Detect_Mixer_sb16 then begin;
   SbProDetected := TRUE;               { SB Pro gefunden            }
 end;
 SbGetDspVersion;
 if SbVersMaj >= 4 then begin;          { SB 16 ASP gefunden         }
   Sb16Detected := true;
   SBProDetected := false;
 end;
 Wr_dsp($D1);                           { Lautsprecher ein           }
 getintvec($8+dsp_irq,oldint);          { Alten Interrupt sichern,   }
 setintvec($8+dsp_irq,@dsp_int_sb16);   { auf eigene Routine setzen  }
 irqmsk := 1 shl dsp_irq;               { Interrupt einmaskieren     }
 port[$21] := port[$21] and not irqmsk;
end;


{
 ***************************************************************************

                    M I X E R  -  P R O C E D U R E N

 ***************************************************************************
}


PROCEDURE Write_Mixer(Reg, Val: BYTE);
{
 Schreibt den in Val bergebenen Wert an das in Reg angegebene
 Register des Mixer - Chips
}
begin;
 Port[dsp_adr+$4] := Reg;
 Port[dsp_adr+$5] := Val;
END;


FUNCTION Read_Mixer(Reg: BYTE) : BYTE;
{
 Die Function liefert den Inhalt des ber Reg indizierten Registers
 des Mixer-Chips
}
begin;
  Port[dsp_adr+$4] := Reg;
  Read_Mixer := Port[dsp_adr+$5];
end;

procedure Filter_Ein;
{
 Diese Procedure Stellt den Tiefen Filter ein bzw. regelt das
 Bass/Treble Register entsprechend
}
var hilfe : byte;
begin;
 if sb16detected then begin;
   write_Mixer(68,64);                  { Treble runter              }
   write_Mixer(69,64);
   write_Mixer(70,255);                 { Bass voll Power !          }
   write_Mixer(71,255);                 { Bass voll Power !          }
 end else begin;
   hilfe := read_Mixer($0c);            { Tiefer Filter              }
   hilfe := hilfe or 8;
   Write_Mixer($0c,hilfe);
   hilfe := read_Mixer($0e);            { Filter einschalten         }
   hilfe := hilfe AND 2;
   write_Mixer($0e,hilfe);
 end;
end;

procedure Filter_MID;
{
 Diese Procedure Stellt den Tiefen Filter ein bzw. regelt das
 Bass/Treble Register entsprechend
}
var hilfe : byte;
begin;
 if sb16detected then begin;
   write_Mixer(68,160);                 { Treble runter              }
   write_Mixer(69,160);
   write_Mixer(70,192);                 { Bass voll Power !          }
   write_Mixer(71,192);                 { Bass voll Power !          }
 end else begin;
   hilfe := read_Mixer($0e);            { Filter ausschalten         }
   hilfe := hilfe OR 32;
   write_Mixer($0e,hilfe);
 end;
end;

procedure Filter_aus;
var hilfe : byte;
begin;
 if sb16detected then begin;
   write_Mixer(68,192);                 { zurck auf default         }
   write_Mixer(69,192);
   write_Mixer(70,160);
   write_Mixer(71,160);
 end else begin;
   hilfe := read_Mixer($0c);            { H”hen-Filter               }
   hilfe := hilfe OR 247;
   Write_Mixer($0c,hilfe);
   hilfe := read_Mixer($0e);            { Filter einschalten         }
   hilfe := hilfe AND 2;
   write_Mixer($0e,hilfe);
 end;
end;

procedure Set_Balance(Wert : byte);
{
 Die Procedure Setzt die Balance entsprechend dem bergebenen Wert.
 Dabei steht 0 fr ganz links, 12 fr Mitte und 24 fr ganz rechts
}
Var left,right : byte;
begin;
 if Sb16Detected then begin;
   left  := 12;
   right := 12;
   if Wert < 12 then right := wert;
   if Wert > 12 then left  := 24-Wert;
   write_Mixer(50,(left  shl 4));
   write_Mixer(51,(right shl 4));
 end else begin;
  Wert := Wert SHR 1;
  case Wert of
     0..6 : begin;
               write_Mixer(02,(7 shl 5)+(Wert shl 1));
             end;
       07 : begin;
               write_Mixer(02,(7 shl 5)+(7 shl 1));
             end;
	  08..13 : begin;
               write_Mixer(02,((13-Wert) shl 5)+(7 shl 1));
	           end;
	 end;
 end;
end;

procedure Set_Volume(Wert : byte);
{
 Zum Setzen der Abspiel-Lautst„rke. Zul„ssige Werte von 0 bis 31
}
begin;
  if sb16detected then begin;
    write_Mixer(48,(Wert shl 3));
    write_Mixer(49,(Wert shl 3));
  end else begin;
    if MixerDetected then begin;
      Wert := Wert Shr 2;
      write_Mixer($22,(wert shl 5) + (wert shl 1));
    end;
  end;
end;

procedure reset_Mixer; assembler;
{
 Resettet den Mixer Chip auf seine Default - Werte
}
asm
  mov dx,dsp_adr+$4
  mov al,0
  out dx,al
  mov cx,50
@loop:
  loop @loop
  inc dx
  out dx,al
end;

FUNCTION Detect_Mixer_sb16 : BOOLEAN;
{
 Function zu Erkennung des Mixer-Chips. TRUE, wenn der Mixer gefunden
 wurde, ansonsten FALSE
}
VAR SaveReg : WORD;
    NewReg  : WORD;
BEGIN
  Detect_Mixer_sb16 := MixerDetected;
  IF (NOT SbRegDetected)                { Abbruch, wenn keine Sound- }
  OR MixerDetected THEN EXIT;           { blaster-Karte vorhanden    }
                                        { oder Mixer-Chip schon      }
                                        { initalisiert               }
  Reset_Mixer;
  SaveReg := Read_Mixer($22);           { Register sichern           }
  Write_Mixer($22, 243);                { Wenn der geschribene wert  }
  NewReg  := Read_Mixer($22);           { mit dem zurckgelesenen    }
                                        { bereinstimmt, so ist ein  }
                                        { Zugriff m”glich und somit  }
                                        { ein Mixer vorhanden        }
  IF NewReg = 243 THEN begin;
    MixerDetected := TRUE;
    STEREO := True;
  end;
  Write_Mixer($22, SaveReg);            { Altes Register zurck      }
  Detect_Mixer_sb16 := MixerDetected;
END;


procedure exit_song;
begin;
 Port[dsp_adr+$C] := $D3;
 halt(0);
end;

{$F+}
procedure MODExitProc;
var mlj : byte;
 begin
 ExitProc := SaveExitProc;
 Exit_Sb16;
end;
{$F-}

{
  **************************************************************************
               V O C  -  P l a y e r      R o u t i n e n

    zur Demonstration der Ausgabe von VOC - Files, keine gesonderte
    VOC-Block-Behandlung integriert
  **************************************************************************
}


procedure Init_Voc(filename : string);
const VOCkenn : string = 'Creative Voice File'+#$1A;
var ch : char;
    kennstr : string;
    ct : byte;
    h : byte;
    error : integer;
    srlo,srhi : byte;
    SR : word;
    Samplingr : word;
    stereoreg : byte;
begin;
  Transfer_Testing := false;
  VOC_READY   := false;
  vocsstereo := stereo;
  stereo := false;

  assign(vocf,filename);
  reset(vocf,1);
  if filesize(vocf) < 5000 then begin;
    VOC_READY   := true;
    exit;
  end;
  blockread(vocf,voch,$19);
  kennstr := voch.Kennstr;
  if kennstr <> VOCkenn then begin;
    { Kennung falsch ! }
    VOC_READY   := true;
    exit;
  end;

  Blockread(vocf,inread,20);
  vblock.Kennung := inread[2];

  if vblock.Kennung = 1 then begin;
    vblock.SR := inread[6];
  end;

  if vblock.Kennung = 8 then begin;
    SR := inread[6]+(inread[7]*256);
    Samplingr := 256000000 div (65536 - SR);
    if inread[9] = 1 then begin; {stereo}
      if sb16detected then samplingr := samplingr shr 1;
      stereo := true;
    end;
    vblock.SR := 256 - longint(1000000 DIV samplingr);
  end;

  if vblock.Kennung = 9 then begin;
    Samplingr := inread[6]+(inread[7]*256);
    if inread[11] = 2 then begin; {stereo}
      stereo := true;
      if sbprodetected then samplingr := samplingr * 2;
      vblock.SR := 256 - longint(1000000 DIV (samplingr));
    end else begin;
      vblock.SR := 256 - longint(1000000 DIV samplingr);
    end;
  end;


  if vblock.SR < 130 then vblock.SR := 166;
  set_timeconst_sb16(vblock.SR);

  blockgr := filesize(vocf) - 31;
  if blockgr > 2500 then blockgr := 2500;
  blockread(vocf,blk1^,blockgr);

  ch := #0;
  fgr := filesize(vocf) - 32;
  fgr := fgr - blockgr;
  Block_activ := 1;

  if fgr > 1 then begin;
    blockread(vocf,blk2^,blockgr);
    fgr := fgr - blockgr;
  end;

 Wr_dsp($D1);
 lastone := false;

 if not sb16Detected then begin;
   if Stereo then begin;
     stereoreg := Read_Mixer($0E);
     stereoreg := stereoreg OR 2;
     Write_Mixer($0E,stereoreg);
   end else begin;
     stereoreg := Read_Mixer($0E);
     stereoreg := stereoreg AND $FD;
     Write_Mixer($0E,stereoreg);
   end;
 end;

 Spiele_Block_Dsp(blockgr,blk1,false,true);
end;

procedure voc_done;
var h : byte;
begin;
 lastone := true;
 repeat until dsp_rdy_sb16;
 close(vocf);
 Reset_SBCard;
 stereo := vocsstereo;
end;

begin;
 SaveExitProc := ExitProc;
 ExitProc := @MODExitProc;
 dsp_rdy_sb16 := true;
 getmem(blk1,2500);
 getmem(blk2,2500);
end.
data segment
c equ 523                       ;Frequenzen der T”ne
d equ 587
e equ 659
f equ 698
g equ 784
a equ 880
h equ 988

Song:     dw c,250, d,250, e,250, f,250, g,500, g,500
          dw a,250, a,250, a,250, a,250, g,500
          dw a,250, a,250, a,250, a,250, g,500
          dw f,250, f,250, f,250, f,250, e,500, e,500
          dw d,250, d,250, d,250, d,250, c,500
          dw 0                  ;Abschluá immer mit 0

oldInt     dd 0                 ;Zeiger auf alten Handler
Zaehler   dw 0                  ;Zaehler, wird einmal pro ms dekrem.
data ends

code segment
assume cs:code,ds:data

handler proc far                ;neuer IRQ 0 - Handler
  pushf
  call dword ptr oldint         ;alten Handler aufrufen
  mov ax,data                   ;Datensegment Zugriff erm”glichen
  mov ds,ax
  dec word ptr Zaehler          ;Zaehler dekrementieren
  iret
handler endp

prepare proc near               ;bereitet Timer und Speaker vor
  mov dx,61h                    ;Controll-Port laden
  in al,dx
  or al,3                       ;untere Bits setzen (enable Speaker)
  out dx,al

  mov al,36h                    ;Schreibzugriff Timer 0
  mov cx,04a9h                  ;Interrupt-Abstand 1 ms
  out 43h,al                    ;Befehl senden
  mov al,cl
  out 40h,al                    ;Timer-Wert senden
  mov al,ch
  out 40h,al

  mov ax,3508h                  ;alten Interrupt-Vektor lesen
  int 21h
  mov word ptr oldint,bx        ;Vektor sichern
  mov word ptr oldint+2,es
  push ds
  mov ax,cs                     ;Vektor auf Handler in ds:dx
  mov ds,ax
  lea dx,handler
  mov ax,2508h                  ;und neuen Vektor setzen
  int 21h
  pop ds
  ret
prepare endp

close proc near                 ;setzt Timer und Speaker wieder zurck
  push ds
  lds dx,oldint                 ;alten Vektor restaurieren
  mov ax,2508h
  int 21h

  mov al,36h                    ;Timer zurcksetzen
  out 43h,al
  xor al,al
  out 40h,al                    ;auf 18,2 Interrupts pro Sekunde
  out 40h,al

  mov dx,61h                    ;Speaker aus
  in al,dx
  and al,not 3                  ;(Speaker enable l”schen)
  out dx,al
  pop ds
  ret
close endp

delay proc near                 ;wartet (Zeit in ms in ax)
  mov zaehler,ax                ;Zaehler laden
warte:
  cmp zaehler,0                 ;warten, bis Interrupt
  jne warte                     ;Zaehler auf 0 gez„hlt hat
  ret
delay endp

sound proc near
  mov bx,ax                     ;Frequenz nach bx
  mov al,0b6h                   ;Timer 2 auf Rechteck programmieren
  out 43h,al
  mov dx,0012h                  ;1.193 MHz Eingangsfrequenz
  mov ax,34ddh
  div bx                        ;Timer-Wert berechnen
  out 42h,al                    ;Low-Byte an Timer 2
  mov al,ah
  out 42h,al                    ;High-Byte an Timer 2
  ret
sound endp

start proc
  mov ax,data                   ;Zugriff auf Datensegment erm”glichen
  mov ds,ax

  call prepare                  ;Timer und Speaker initialisieren

  lea si,song                   ;Zeiger auf Frequenzen

weiter:
  lodsw                         ;Frequenz holen
  or ax,ax
  je fertig                     ;Abschluá-Byte gefunden ?
  call sound                    ;Sound ausgeben
  lodsw                         ;Dauer laden
  call delay                    ;und warten
  jmp weiter

fertig:
  call close                    ;Timer und Interrupts zurcksetzen
  mov ah,4ch                    ;Programm beenden
  int 21h
start  endp

code ends
end start
uses crt,dos;
const voclast:Byte=0;           {letzter Wert}
      trigger=5;                {Empfindlichkeit}
      fertig:Boolean=false;     {fertig ?}
var   oldint8:Pointer;          {alter IRQ 0 Handler}
      Voc:Pointer;              {Zeiger auf Sample-Daten im Speicher}
      VocFile:File;             {Voc-Datei}
      timwert,                  {Wert fr Timer-Chip}
      vocpos,                   {aktueller Offset in Voc-File}
      voclen,                   {L„nge des Voc-Files}
      Hz:Word;                  {Sample-Frequenz}

Procedure Play;interrupt;assembler;
{spielt Voc im Interrupt ab}
asm
  mov dx,61h                    {Inhalt des Controll Ports lesen}
  in al,dx
  mov cl,al                     {und in cl sichern}
  les di,voc                    {es:di mit Zeiger auf Sample-Daten laden}
  inc vocpos                    {Position um 1 weiter}
  mov ax,vocpos                 {in ax laden}
  add di,ax                     {und auf Speicher-Offset addieren}
  cmp ax,voclen                 {bereits Sample-Ende erreicht ?}
  jne @ok                       {ja,}
  mov fertig,1                  {dann flag setzen}
@ok:
  mov al,es:[di]                {sonst Wert holen}
  mov bl,al                     {in bl sichern}
  sub al,voclast                {Differenz zum letzten Wert bilden}
  mov voclast,bl                {und Wert als letzten Wert vermerken}
  cmp al,trigger                {Abstand grӇer als Ansprechschwelle ?}
  jg @set                       {dann Speaker auf high setzen}
  cmp al,-trigger               {Abstand kleiner als negative Ansprechschw. ?}
  jg @ende                      {nein, dann fertig}
  mov al,cl                     {alten Inhalt d. Control-Ports}
  and al,not 2                  {Bit 1 l”schen}
  out dx,al                     {und schreiben}
  jmp @ende                     {fertig}
@set:
  mov al,cl                     {alten Inhalt d. Control-Ports}
  or al,2                       {Bit 1 setzen}
  out dx,al                     {und schreiben}
@ende:
  pushf                         {alten Handler aufrufen}
  call [oldint8]
End;

begin
  Assign(VocFile,'rythm.voc');  {File ”ffnen}
  Reset(VocFile,1);             {Zurcksetzen}
  Voclen:=FileSize(VocFile);    {L„nge ermitteln}
  GetMem(Voc,Voclen);           {entsprechend Speicher allokieren}
  BlockRead(VocFile,Voc^,FileSize(VocFile));
                                {Voc-File einlesen (max. 64kB)}
  Close(VocFile);               {und schlieáen}
  Hz:=1000000 div               {Sample-Frequenz aus Datei ermitteln}
    (256-Byte(Ptr(Seg(Voc^),Ofs(Voc^)+$1f)^));

  GetIntVec($8,OldInt8);        {Vektor IRQ 0 sichern}
  SetIntVec($8,@Play);          {IRQ 0 auf Handler verbiegen}

   timwert := 1193180 DIV Hz;   {aus Sampling-Frequenz Timer-Start berechn.}
  Port[$43]:=$36;               {diesen auf Z„hler 0 programmieren}
   Port[$40]:=Lo(timwert);
   Port[$40]:=Hi(timwert);

  Repeat Until KeyPressed or fertig;  {warten, bis Ende oder Taste}

  SetIntVec($8,OldInt8);        {Vektor wieder herstellen}
  Port[$43]:=$36;               {Timer zurcksetzen}
   Port[$40]:=0;                {(18,2 Hz)}
   Port[$40]:=0;
End.
;
;		Vision Factory
; 		Gif Loader
;
; 	Basisversion
; 	(w) by Atan (Matthias Rasch)
;		zusammengestellt am 13.11.93
;
; 	l„dt Gif-Bild 320*200 in Mode 13h
; 	Aufruf siehe Hauptprogramm
.286

	clr=256
	eof=257
  w equ word ptr
  b equ byte ptr

;codeg group code
code segment public
assume cs:code,ds:code
public loadgif
public setpal
public blackpal
public dealloc
extrn p13_2_modex:near
extrn picture:byte

GifRead proc pascal n:word
	push ds
  mov ax,cs
  mov ds,ax
  mov es,ax
  lea di,puf
  lea si,picture
  add si,w picpos
  mov cx,word ptr n
  rep movsb
  mov ax,n
  add w picpos,ax
  pop ds
  ret
endp
GifSeekdelta proc pascal delta:dword
	mov ax,04200h
  mov bx,w handle
  mov cx,word ptr delta + 2
  mov dx,word ptr delta
  int 21h
  ret
Endp
ShiftPal proc pascal
	push ds
	mov ax,cs
  mov es,ax
  mov ds,ax

  mov si,offset Puf
  mov di,offset Palette
  mov cx,768
@l1:
	lodsb
  shr al,2
  stosb
  loop @l1
  pop ds
  ret
Endp
FillPuf proc pascal
  push 1
  call gifread
  mov al,b puf[0]
  xor ah,ah
  mov w restbyte,ax
	push ax
  call gifread
  ret
Endp

GetPhysByte proc pascal
	push bx
	cmp w restbyte,0
  ja @restda
  pusha
  push es
  call fillpuf
  pop es
  popa
	mov w pufind,0
@restda:
  mov bx,w PufInd
  mov al,b Puf[bx]
  inc w pufind
  pop bx
  ret
Endp

GetLogByte proc pascal
  push si
	mov ax,w breite
	mov si,ax
  mov dx,w restbits
  mov cx,8
  sub cx,dx
  mov ax,w lByte
  shr ax,cl
  mov w akt_code,ax
  sub si,dx
@nextbyte:
  call getphysbyte
  xor ah,ah
  mov w lByte,ax
  dec w restbyte

  mov bx,1
  mov cx,si
  shl bx,cl
  dec bx
  and ax,bx

  mov cx,dx
  shl ax,cl
  add w akt_code,ax

  sbb dx,w breite
  add dx,8
  jns @positiv
  add dx,8
@positiv:
  sub si,8
  jle @fertig
	add dx,w breite
  sub dx,8
  jmp @nextbyte
@fertig:
	mov w restbits,dx
  mov ax,w akt_code
	pop si
  ret
Endp
err_mem db 'zu wenig Speicher$'
getvmem proc pascal
  mov ax,cs
  mov es,ax
  mov bx,20000d
	mov ah,4ah
  int 21h

  mov ah,48h
  mov bx,2001d 						;(32000/16+1)
  int 21h
  jae ok								;sprung,wenn carry 0

  mov ax,3
  int 10h
  mov ax,cs
  mov ds,ax
  mov ah,9
  mov dx,offset err_mem
  int 21h
  mov ah,4ch
  mov al,1
  int 21h
ok:
  mov word ptr vscreen+2,ax
  ret
getvmem endp
dealloc proc pascal
	mov ah,49h
  les di,cs:dword ptr vscreen
  int 21h
	ret
dealloc endp



LoadGif proc pascal
	push ds
  mov ax,cs
  mov ds,ax

;	call GifOpen
;  push 0
;  push 13
;  call gifseekdelta
  push 768
  call gifread
  call shiftpal
  push 1
  call gifread

@extloop:
  cmp w puf[0],21h
  jne @noext
	  push 2
    call gifread
    mov al,b puf[1]
    inc al
    xor ah,ah
    push ax
    call gifread
  jmp @extloop
@noext:
  push 10
  call gifread
  test b puf[8],128
  je @nolok
	  push 768
  	call gifread
    call shiftpal
@nolok:
  mov w lbyte,0
    call getvmem
		les di,dword ptr vscreen

    mov w free,258
    mov w breite,9
    mov w max,511
    mov w stackp,0
    mov w restbits,0
    mov w restbyte,0
  @mainloop:
    call getlogByte
		cmp ax,eof
    jne @no_abbruch
    jmp @abbruch
  @no_abbruch:
    cmp ax,clr
    jne @no_clear
    jmp @clear
  @no_clear:
  	mov w readbyt,ax
    cmp ax,w free
    jb @code_in_ab
    mov ax,w old_code
    mov w akt_code,ax
    mov bx,w stackp
    mov cx,w sonderfall
    mov w abstack[bx],cx
    inc w stackp
  @code_in_ab:
  	cmp ax,clr
  	jb @konkret
  @fillstack_loop:
    mov bx,w akt_code
    shl bx,1
    push bx
    mov ax,w ab_tail[bx]
    mov bx,w stackp
    shl bx,1
    mov w abstack[bx],ax
    inc w stackp
    pop bx
    mov ax,w ab_prfx[bx]
    mov w akt_code,ax
    cmp ax,clr
    ja @fillstack_loop
  @konkret:
  	mov bx,w stackp
    shl bx,1
    mov w abstack[bx],ax
    mov w sonderfall,ax
    inc w stackp
    mov bx,w stackp
    dec bx
    shl bx,1
  @readstack_loop:
  	mov ax,w abstack[bx]
		stosb
    cmp di,32003
    jbe @noovl1
    call p13_2_modex pascal,0,8001
		les di,dword ptr vscreen
@noovl1:
		dec bx
    dec bx
    jns @readstack_loop
    mov w stackp,0
    mov bx,w free
    shl bx,1
    mov ax,w old_code
    mov w ab_prfx[bx],ax
    mov ax,w akt_code
    mov w ab_tail[bx],ax
    mov ax,w readbyt
    mov w old_code,ax
    inc w free
    mov ax,w free
    cmp ax,w max
    ja @no_mainloop
    jmp @mainloop
	@no_mainloop:
    cmp b breite,12
    jb @no_mainloop2
    jmp @mainloop
  @no_mainloop2:
    inc w breite
    mov cl,b breite
    mov ax,1
    shl ax,cl
    dec ax
    mov w max,ax
    jmp @mainloop
  @clear:
    mov w breite,9
    mov w max,511
    mov w free,258
    call getlogbyte
    mov w sonderfall,ax
    mov w old_code,ax
		stosb
    cmp di,32003
    jbe @noovl2
    call p13_2_modex pascal,0,8001
		les di,dword ptr vscreen
@noovl2:
    jmp @mainloop
  @abbruch:
	call dealloc
;	  call gifclose;
  pop ds
  ret
Endp

SetPal proc pascal
  push ds
  push si
  mov ax,cs
  mov ds,ax
  mov si,offset palette
  mov cx,256*3
  xor al,al
  mov dx,03c8h
  out dx,al
  inc dx
@lp:
  rep outsb
  pop si
  pop ds
  ret
Endp
blackpal proc pascal
	mov ax,cs
  mov es,ax
  lea di,palette
  mov cx,256*3/2
  mov ax,0
  rep stosw
  ret
Endp

	handle: 	dw 0
	Puf: 			db 768 dup (0)
  PufInd: 	dw 0
  abStack:	db 1281 dup (0)
  ab_prfx:	dw 2049 dup (0)
	ab_tail:	dw 2049 dup (0)
  Byt:			db 0
  free:			dw 0
	breite:		dw 0
	max:			dw 0
	stackp:		dw 0
	restbits: dw 0
	restbyte: dw 0
	sonderfall: dw 0
  akt_code: dw 0
	old_code: dw 0
	readbyt: 	dw 0
	bits:			dw 0
	bits2get: dw 0
  lbyte:		dw 0
  GifName:	db 'logo_st.gif',0
  Palette:	db 768 dup (0)
  extrn vscreen:dword
  picpos:		dw 13

;lokdata ends
code ends
;Bemerkung: Sollte es mit seeeeehr komplexen Bildern nicht funktionieren,
;	bitte melden, umfangreiche Žnderungen in der Speicherverwaltung
; n”tig. Muáte Speicher sparen.
end

.286
  w equ word ptr
  b equ byte ptr
code segment public
assume cs:code,ds:code
  extrn insthand:near
	extrn loadgif:near
  extrn setpal:near
	extrn p13_2_modex:near
  extrn squeeze:near
  extrn blackpal:near
  extrn init_modex:near
  extrn reslim:byte
	extrn oldint21:dword
  extrn oldint65:dword
  extrn kennung:dword
  extrn makecopy:near
  public resident
  public drawgif
  public deinst
resident proc near
	call insthand
  mov ax,word ptr ds:[2ch]
  mov es,ax
  mov ah,49h
  int 21h
  lea dx,reslim
  inc dx
  int 27h
	ret
resident endp
drawgif proc near
	call init_modex
  call blackpal
  call setpal

	call loadgif
  call p13_2_modex pascal,8001,7999
;	call setpal
  call squeeze

  mov ah,1
  int 21h
  ret
drawgif endp
deinst proc near
	mov ah,49h
  int 21h
	mov dx,es:w oldint21
  mov ax,es:w oldint21 + 2
  mov ds,ax
  mov ax,2521h
  int 21h
	mov dx,es:w oldint65
  mov ax,es:w oldint65 + 2
  mov ds,ax
  mov ax,2565h
  int 21h
  int 20h
deinst endp
code ends
end;                **************************************
;                ***                                ***
;                ***   Trainer zu *********         ***
;                ***                                ***
;                ***   (c) 1994 by DATA Becker      ***
;                ***                                ***
;                ***   Autor: Boris Bertelsons      ***
;                ***                                ***
;                **************************************
;
;

.286
  w equ word ptr
  b equ byte ptr
code segment public
public insthand
public handler21
public reslim
public oldint21
public oldint65
public kennung
public klen
public check_inst

assume cs:code,ds:code
kennung:  db 'DATA BECKER'
oldint21: dd 0
oldint65: dd 0
prozedur: dd ?
klen equ offset oldint21 - offset kennung


;  *********************************************************************
;  ***                                                               ***
;  ***  An dieser Stelle stehen die eigentlichen Trainer - Routinen  ***
;  ***                                                               ***
;  *********************************************************************


;  **********************************************************************
;  ***                                                                ***
;  ***  Der neue INT 21h. Die Procedure prft, ob an der angegebenen  ***
;  ***  Stelle im Speicher der Befehl  "in al,60h" steht, und erstzt  ***
;  ***  diesen ggf. durch  "int 65h" !                                ***
;  ***                                                                ***
;  **********************************************************************
handler21 proc pascal
  pushf
  push bp
  push ds
  push bx
  mov  bp,sp
  mov  bx,[bp+10]  ; cs zur Zeit des Interrupts nach BX, DOS !!!
                   ; WICHTIG ! Im TD [bp+16] !!!
  add  bx,0366h    ; CS des 1. INT 21h + 2136h = CS der Tastaturroutine
  mov  ds,bx       ; cs der Keyboard - Routine nach ds
  mov  bx,568Bh    ; 8B56h = mov dx,[bp+06]
  cmp  ds:word ptr [0005h],bx     ; steht es in der Tastaturroutine ?
  jne  nicht_aendern
  mov  ds:word ptr [0005h],9090h  ; Int 65h reinschreiben !
  mov  ds:word ptr [0007h],65CDh  ; Int 65h reinschreiben !
nicht_aendern:
  pop  bx
  pop  ds
  pop  bp
  popf
  jmp dword ptr cs:oldint21       ; alten Int 21h aufrufen
handler21 endp

;  *************************************************************************
;  ***                                                                   ***
;  ***  Die Int 65h - Procedure. Sie liest ein Zeichen ber "in al,60h"  ***
;  ***  ein, und prft, ob das eingelesene Zeichen als Trainer-Key       ***
;  ***  definiert wurde. Falls ja, werden die zugewiesenen Speicher-     ***
;  ***  ver„nderungen und Procedureaufrufe durchgefhrt. An dieser       ***
;  ***  Stelle máen Sie Ihre Trainingsvariablen eintragen !!!           ***
;  ***                                                                   ***
;  *************************************************************************

handler65 proc far
  pushf
  push bp
  push ds
  push bx
  mov  bp,sp
  mov  bx,[bp+10]  ; cs zur Zeit des Interrupts nach BX
  in  al,60h       ; Zeichen lesen
  cmp al,63        ; Taste F5
  je  Full_Shoots_j
  cmp al,64        ; Taste F6
  je  Full_Lives_J
  cmp al,65        ; Taste F7
  je Weapon_new_j  ;
  cmp al,66        ; Taste F6
  je Weapon_new_j  ;
  cmp al,67        ; Taste F9
  je Weapon_new_j  ;
  cmp al,68        ; Taste F10
  je  More_Points_J

Ende_Keyb:
  pop bx
  pop ds
  pop bp
  popf
  iret

Full_Shoots_j:
  jmp Full_Shoots
Full_Lives_j:
  jmp Full_Lives
More_Points_j:
  jmp More_Points
Weapon_new_j:
  jmp Weapon_new

Full_Shoots:
  pushf
  PUSHA
  sub  bx,0    ; da schon richtiges CS
  mov word ptr prozedur+2,bx
  mov  bx,1401h    ; es:[bx]  =  14EF:1401
  mov word ptr prozedur,bx
;--------
  mov ds:byte ptr [0DA3h],20h
  mov ax,20h
  push ax
  call dword ptr [prozedur]
  POPA
  popf
  jmp Ende_Keyb

Full_Lives:
  pushf
  pusha
  sub  bx,0  ;
  mov word ptr prozedur+2,bx
  mov  bx,1317h  ; es:[bx]  =  14EF:1317
  mov word ptr prozedur,bx
;-----------
  mov ds:byte ptr [0DA3h],0009
  mov ax,9
  push ax
  call dword ptr [prozedur]
  popa
  popf
  jmp Ende_Keyb

Weapon_new:
  pushf
  pusha
  sub  bx,0  ;
  mov word ptr prozedur+2,bx
  mov  bx,1454h  ; es:[bx]  =  14EF:1454
  mov word ptr prozedur,bx
;-----------
  sub al,65
  mov ah,0
  mov ds:byte ptr [0DA2h],al
  push ax
  call dword ptr [prozedur]
  popa
  popf
  jmp Ende_Keyb

More_Points:
  pushf
  pusha
  sub  bx,0  ;
  mov word ptr prozedur+2,bx
  mov  bx,1BD0h  ; es:[bx]  =  14EF:1BD0
  mov word ptr prozedur,bx
;-----------
  mov ax,1000
  push ax
  call dword ptr [prozedur]
  popa
  popf
  jmp Ende_Keyb

handler65 endp

insthand proc pascal
reslim label byte
	push ds
  pop ds
	mov ax,3521h                    ; alten INT 21 sichern
  int 21h
  mov w oldint21,bx
  mov w oldint21 + 2,es
	mov ax,3565h                    ; alten INT 65h sichern
  int 21h
  mov w oldint65,bx
  mov w oldint65 + 2,es
  mov ax,2521h                    ; INT 21h auf eigene Routine verbiegen
  lea dx,handler21
  int 21h
  mov ax,2565h                    ; INT 65h auf eigene Keyboard-Routine
  lea dx,handler65
  int 21h
 	ret
insthand endp

check_inst proc near
  mov ax,3521h                    ; Interrupt - Vektor ermitteln
  int 21h
  mov di,bx
  mov si,offset kennung
  mov di,si
  mov cx,klen
  repe cmpsb                      ; Auf Kennung prfen
	ret
check_inst endp

code ends
end
.286
  w equ word ptr cs:
  b equ byte ptr cs:
;code segment public
;code ends
code segment public
;gcode group code,arescode
assume cs:code,ds:code
extrn setpal:near
public init_modex,p13_2_modex,squeeze
public vscreen

Init_ModeX proc pascal
	mov ax,0013h
  int 10h

  mov dx,3c4h
  mov al,4
  out dx,al
  inc dx
  in al,dx
  and al,0f7h
  or al,4h
  out dx,al
  dec dx
  mov ax,0f02h
  out dx,ax

	mov ax,0a000h
  mov es,ax
  xor di,di
  xor ax,ax
  mov cx,8000h
  cld
  rep stosw

  mov dx,3d4h
  mov al,14h
  out dx,al
  inc dx
  in al,dx
  and al,0bfh
  out dx,al
  dec dx
  mov al,17h
  out dx,al
  inc dx
  in al,dx
  or al,40h
  out dx,al
  ret
Endp

plane_l: db 0
plane_pos: dw 0
vscreen: dd 0

p13_2_modex proc pascal start,pic_size:word
		mov b plane_l,1
    mov w plane_pos,0
    push ds
    lds si,dword ptr cs:vscreen
    mov w plane_pos,si
    mov ax,0a000h
    mov es,ax
    mov di,start
    mov cx,pic_size
@lpplane:
    mov al,02h
    mov ah,b plane_l
    mov dx,3c4h
    out dx,ax

	@lp1:
    movsb
    add si,3
    loop @lp1

		mov di,start
    inc w plane_pos
    mov si,w plane_pos
    mov cx,pic_size
    shl b plane_l,1
    cmp b plane_l,10h
    jne @lpplane

    pop ds
    ret
Endp
Split proc pascal row:byte
	mov bl,row
  xor bh,bh
	shl bx,1
  mov cx,bx

	mov dx,3d4h
  mov al,07h
  out dx,al
  inc dx
  in al,dx
	and al,11101111b
  shr cx,4
  and cl,16
  or al,cl
  out dx,al

  dec dx
  mov al,09h
  out dx,al
  inc dx
  in al,dx
  and al,10111111b
  shr bl,3
  and bl,64
  or al,bl
  out dx,al

  dec dx
  mov al,18h
  mov ah,row
  shl ah,1
  out dx,ax
  ret
Endp
SetStart proc pascal t:word
	mov dx,3d4h
  mov al,0ch
  mov ah,byte ptr t + 1
  out dx,ax
  mov al,0dh
  mov ah,byte ptr t
  out dx,ax
  ret
Endp
WaitRetrace proc pascal
	mov dx,3dah
@wait1:
	in al,dx
  test al,8h
	jz @wait1
@wait2:
	in al,dx
  test al,8h
  jnz @wait2
	ret
Endp

squeeze proc pascal
	mov si,200*80
  mov di,199
  push di
  call split
  push si
  call setstart
  call waitretrace
  call setpal
sqlp:
  call waitretrace
  push di
  call split
  push si
  call setstart
  sub si,2*80
  sub di,2
  cmp di,99d
  jae sqlp
	ret
squeeze endp
code ends
end
.286
code segment public
assume cs:code,ds:code
extrn resident:near
extrn drawgif:near
extrn reslim:byte
extrn check_inst:near
extrn deinst:near
org 100h
main proc
  call check_inst
  jcxz deinstall

  call drawgif
  mov ax,03h
  int 10h

  lea dx,text_ins
  mov ah,9h
  int 21h
	jmp resident
deinstall:
  lea dx,text_deinst
  mov ah,9h
  int 21h
  jmp deinst

  mov ax,20h
  int 21h
main endp
	text_ins: db 'Trainer installed$'
  text_deinst: db 'Trainer deinstalled$'
code ends
end main