Power-Programmierung/CD1.mdf/pascal/library/dos/sound/sampler/sampler.inc

Text File | 1989-05-04 | 42.0 KB | 1,451 lines

{ Utility procedures for sampler.pas}


{$f+}
procedure samplerexit; {$f-}

{ incase graphics mode, restore text screen before error message is given
  also restores keyboard interrupt on abort}

begin {samplerexit}
mem[0 : $417] := mem[0 : $417] And $fc; {shift off}
restorecrtmode;
exitproc:=exitsave;
if showerrormessage then
  writeln('Exit due to internal error!');
if customkbd then
  restore;
end; {samplerexit}


function index(position:longint):longint;

{ calculates buffer array index for given screen position}

begin {index}
if zoom then
  index:=viewleft+position - plotxoffset
else
  index:=Round((position - plotxoffset)
         / (getmaxx - 2 * plotxoffset) * bufflength);
end;{index}

function scaleord(index:longint):integer;

{ calculates screen position for indexth position in buffer array}

begin {scaleord}
if zoom then
  scaleord:=index-viewleft+plotxoffset
else
  scaleord:= Round(index / bufflength * (getmaxx - 2 * plotxoffset)
                   + plotxoffset); {move to end of read data}
end; {scaleord}


  Function keypress : Boolean;

    { assumes custom keyboard service is installed. checks if a key has been
    pressed and released}

  Begin
    If kbdflag > 0 Then
      Case keyval Of
        42 : mem[0 : $417] := mem[0 : $417] Or 2; {lshift down}
        54 : mem[0 : $417] := mem[0 : $417] Or 1; {rshift down}
        170 : mem[0 : $417] := mem[0 : $417] And $fd; {lshift release}
        182 : mem[0 : $417] := mem[0 : $417] And $fe; {rshift release}
      End;                        {case}
    keypress := (kbdflag > 0) And (keyval < 128);
  End;  {keypress}



  Function get_inc(tune : Integer; c : Char) : Integer;

    { returns a fractional increment value for a given key based on 12th root
      of 2}

  Begin
    get_inc := Round(tune * Exp(kbdmap[c] * 0.057762265));
                            {= (12th root of 2)^kbdmap[c] * tune}
  End;   {get_inc}


  Procedure display_title(title_string:string; font, fontsize,
                          bcolor,color:word);

    { displays nice big bold title}

  Begin
    settextstyle(font, horizdir, fontsize);
    settextjustify(centertext, toptext);
    panel(getmaxx Div 2, 1, getmaxx-cornersize*2, Round(textheight(titlestring) * 1.1),
      bcolor);
    selectcolor(color);
    outtextxy(getmaxx Div 2, - 4, title_string);
  End;   {display_title}


  Procedure display_pointers(leftord,rightord,loopord:longint;
                             leftshow,rightshow,loopshow:boolean);

    { displays up to 3 pointers}

  Begin
    if leftshow and (leftord>=viewleft) and (leftord<=viewright) then
      putimage(scaleord(leftord) - arrowxoff, arrowlowy, uparrowp^, xorput);
    if rightshow and (rightord<=viewright) and (rightord<=viewright) then
      putimage(scaleord(rightord) - arrowxoff, arrowlowy, uparrowp^, xorput);
    if loopshow and (loopord>=viewleft) and (loopord<=viewright) then
      putimage(scaleord(loopord) - arrowxoff, arrowhighy, downarrowp^, xorput);
  End;                            {display_pointers}


  Procedure highlight_directory_entry(fileno : Integer; extension:boolean;
                                      highlight : Boolean);

    { highlights the currently selected file or restores if highlight=false
      if extension=true then the file extension is shown also}

  Var j, x, y : Integer;
    str1 : String;

  Begin
    settextstyle(smallfont, horizdir, 4);
    settextjustify(lefttext, toptext);
    str1:=copy(bigemptystring,1,dirnamefieldwidth);
    j := pos('.', dir[fileno]);
    if extension or (j=0) then
       j:=succ(length(dir[fileno]));
    If highlight Then
      Begin
        selectcolor(dirhcolor);
        selectfillstyle(solidfill, dircolor);
      End
    Else
      Begin
        selectcolor(dircolor);
        selectfillstyle(solidfill, dirbcolor);
      End;
    x := cornersize
         + (Pred(fileno) Mod dirnamesperline) * textwidth(str1);
    y := directoryyoff
         + Pred(fileno) Div dirnamesperline * textheight(' ');
    bar(x, y+1, x + textwidth(Copy(str1, 1, 8)),
        y + textheight(' ') );
    outtextxy(x, y, Copy(dir[fileno], 1, Pred(j)));
  End;  {highlight_directory_entry}


  Procedure getdirectory(Var dir : directory_type; pattern : String);

    {read file names in current directory matching pattern to dir}

  Var dirinfo : searchrec;
    fileno,i : Integer;

  Begin
    findfirst(path+'\'+pattern, 0, dirinfo);
    fileno := 1;
    While doserror = 0 Do
      Begin
        dir[fileno] := dirinfo.name;
        i:=pos('.',dir[fileno]);
        if i in [1..8] then
          dir[fileno]:=copy(copy(dir[fileno],1,pred(i))+'        ',1,8)+
                       copy(dir[fileno],i,4);    {right justify extension}
        Inc(fileno);
        findnext(dirinfo);
      End;
    dir[fileno] := '';            {mark end of list}
  End; {getdirectory}


  Procedure showdirectory(extension:string);

    { displays files with extension in current directory}


  var i,j,k:integer;

  Begin
    settextstyle(smallfont, horizdir, 5);
    settextjustify(lefttext, toptext);
    fill_background(dirbcolor,solidfill,cornersize);
    selectcolor(dircolor);
    getdirectory(dir, '*.'+extension);
    if extension='*' then
      extension:='All';
    outtextxy(cornersize, 0, extension+' files on  ' +
              path);
    directoryyoff:=round(textheight(' ')*1.3);
    i := 1;
    While (dir[i]<>'') and (dir[Succ(i)] <> '') Do   {sort dir}
      Begin
        j := Succ(i);
        While dir[j] <> '' Do
          Begin
            If dir[j] < dir[i] Then {name out of sequence}
              Begin
                str1 := dir[j];
                For k := Pred(j) Downto i Do {shift names down list}
                  dir[Succ(k)] := dir[k];
                dir[i] := str1;   {insert name in correct place}
              End;
            j := Succ(j);
          End;
        i := Succ(i);
      End;
    str1 := '';
    For i := 1 To dirnamefieldwidth Do
      str1 := str1 + ' ';
    i := 1;
    While dir[i] <> '' Do
      Begin
        highlight_directory_entry(i, (extension='All'),False);
        i := Succ(i);
      End;
    filesavail := Pred(i);
    settextstyle(smallfont, horizdir, 4);
    settextjustify(lefttext, toptext);
    Str(diskfree(0) shr 10, str1);
    outtextxy(cornersize,
              directoryyoff+(filesavail div dirnamesperline +1)
              *textheight(' '),' With ' + str1 + ' k free');
  End;  {showdirectory}


  procedure pickfile(extension:string; var pick:string);

  { shows directory list, then allows file selection by mouse or naming
   specifically}

  var j:integer;
      c:char;
      cp:clickboxtypep;
      dp:dialogentryp;
      manual:boolean;

  function strip(s:string):string;

  { strips spaces from string and converts to lower case}

  var i:integer;

  begin
  i:=pos(' ',s);
  while i>0 do
  begin
    delete(s,i,1);
    i:=pos(' ',s);
  end;
  for i:=1 to length(s) do
    if s[i] in ['A'..'Z'] then
      s[i]:=chr(ord(s[i])+ord('a')-ord('A'));
  strip:=s;
  end; {strip}

function selection:integer;

{ determines which (if any) file bar was selected}

var boxwidth,boxheight,sel:integer;

begin {selection}
boxwidth:=textwidth(copy(bigemptystring,1,dirnamefieldwidth));
boxheight:=textheight(' ');
if   (mousex>cornersize) and
     (mousex-cornersize<boxwidth*dirnamesperline) and
     ((mousex -cornersize) mod boxwidth
      < textwidth(copy(bigemptystring,1,8))) and
     (mousey>directoryyoff) and
     (mousey-directoryyoff
      <(pred(filesavail) div dirnamesperline +1)*boxheight) then
begin
  sel:=(mousex-cornersize) div boxwidth +
       ((mousey-directoryyoff) div boxheight )*dirnamesperline+1;
  if sel>filesavail then
    selection:=-1
  else
    selection:=sel;
end
else
  selection:=-1;
end; {selection}


  begin {pickfile}
    mousearrowoff;
    showdirectory(extension);
    settextstyle(defaultfont,horizdir,1);
    selectcolor(dialogcolor);
    selectfillstyle(solidfill,dialogbcolor);
    new(cp);
    with cp^ do
    begin
      ttype:=_text;
      title:='Specify input file';
      x:=0;
      y:=0;
      next:=nil;
    end;
    draw_clicklist(cp,cornersize,getmaxy-textheight(' ')*2,clickbcolor,clickcolor);
    mousearrowon;
    j:=-1;
    settextstyle(smallfont, horizdir, 4);
    settextjustify(lefttext, toptext);
    manual:=false;
    repeat
      repeat
        c:=trackmouse;
      until (mousekeys>0) or (c in [^c,^m]);
      if c=^m then
        manual:=true;
      if mousekeys>1 then
      begin
        pick:='';
        j:=0;
      end
      else
      if mousekeys=1 then
      begin
        settextstyle(defaultfont,horizdir,1);
        if click_selection(cp,cornersize,getmaxy-textheight(' ')*2)>-1 then
        begin
          draw_clicklist(cp,cornersize,getmaxy-textheight(' ')*2,clickcolor,
                         clickbcolor);
          manual:=true;
        end
        else
        begin
          settextstyle(smallfont,horizdir,4);
          j:=selection;
        end;
      end
      else
        j:=-1;
    until (j>-1) or manual or (c=^c);
    mousearrowoff;
    if not manual and (j>0) and (dir[j]<>'') then
    begin
      highlight_directory_entry(j, (extension='*'),true);
      pick:=dir[j];
      repeat
        j:=pos(' ',pick);
        if j>0 then
          delete(pick,j,1);
      until j=0;
    end;
    if manual then
          Begin
            new(dp);
            with dp^ do
            begin
              title:='Name of input file (.'+extension+') (' + #17 +'--+ to skip):';
              argtype:=_string;
              ssize:=30;
              stringresult:='';
              next:=nil;
            end;
            settextstyle(defaultfont,horizdir,1);
            dialog_box(dp,dialogbcolor,dialogcolor,false);
            pick:=dp^.stringresult;
            dispose(dp);
            if (pick<>'') and (pos('.',pick)=0) then
              pick:= strip(pick + '.'+extension);
          End;
    mousearrowon;
    dispose(cp);
  end; {pickfile}


procedure cut_region(cutleft,cutright:longint);

{ clears area of buffer following a cut operation}

begin {cut_region}
fillchar(buffer^[cutleft],cutright-cutleft+1,127);
end; {cut_region}

procedure set_bounds;

{ recalculates boundary values for current pointer positions}

begin {set_bounds}
{$ifdef pwm}
        bufstart := Ofs(bufferw^[leftord]);
        bufend := Ofs(bufferw^[rightord]);
        bufloop := Ofs(bufferw^[loopord]);
{$else}
        bufstart := Ofs(buffer^[leftord]);
        bufend := Ofs(buffer^[rightord]);
        bufloop := Ofs(buffer^[loopord]);
{$endif}
end; {set_bounds}


  procedure move_pointers(d1,d2,d3:integer);

    { move pointers by given delta values}

  var lefttemp,righttemp,looptemp:longint;
      unlimited:boolean;

  Begin
    lefttemp:=leftord;
    righttemp:=rightord;
    looptemp:=loopord;
    leftord:=leftord+index(d1-viewleft+plotxoffset);
    rightord:=rightord+index(d2-viewleft+plotxoffset);
    loopord:=loopord+index(d3-viewleft+plotxoffset);
    If leftord < 0 Then
      leftord := 0;
    If rightord > bufflength Then
      rightord := bufflength;
    If rightord < getmaxx div 5 Then
      rightord := getmaxx div 5;
    If leftord >= rightord-getmaxx div 5 Then
      leftord := rightord - getmaxx div 5;
    If loopord > rightord -getmaxx div 5 Then  {don't let arrows overlap}
      loopord := rightord - getmaxx div 5;
    If loopord < leftord Then
      loopord := leftord;
    display_pointers(lefttemp,righttemp,looptemp,(lefttemp<>leftord),
                     (righttemp<>rightord),(looptemp<>loopord)); {erase pointers}
    display_pointers(leftord,rightord,loopord,(lefttemp<>leftord),
                     (righttemp<>rightord),(looptemp<>loopord)); {show pointers}
  End;   {move_pointers}


  procedure load_sound_file(fn : String; leftlimit,rightlimit:longint;
                            mix:boolean);

{ reads given sound file to the buffer. limits determine edges of allowed
  region for loading. if sound file won't fit, it will be truncated.
  if mix is true, then new file will be mixed with old data}

  Var i,j,k : longint;
    f : File;
    lastdp,dp,dialoghead:dialogentryp;
    reducecut,reduceoriginal,reduceall:boolean;
    cutshift,originalshift:byte;
    offset:integer;
    storagep:pointer;

  Begin
    if (fn[1]<>'\') and (fn[2]<>':') then
      Assign(f, path+'\'+fn)
    else
      Assign(f, fn);
    {$i-}
    Reset(f);
    {$i+}
    If IoResult = 0 Then
      Begin
        i:=0;
        for i:=1 to filesize(f) div (blocksize div 128) do {read whole blocks}
          BlockRead(f, bufferw^[pred(i) * blocksize], blocksize shr 7);
        for j:=1 to filesize(f) mod (blocksize div 128) do {read what's left}
          BlockRead(f, bufferw^[i * blocksize+pred(j)*128], 1);
        loopord := bufferw^[2] + longint(bufferw^[3]) * 256 + plotxoffset;
        i := bufferw^[0] + longint(bufferw^[1]) * 256; {get sample size}

        j:=rightlimit-leftlimit;
        if i<j then
          j:=i;   {copy size is smallest of file size and cutbox size}
        if leftord>leftlimit then
          leftord:=leftlimit;
        if cutboxactive then
        begin
          if j+leftlimit>rightord then
            rightord:=j+leftlimit;
        end
        else
          rightord := j; {move to end of read data}
        if not mix then
          Move(bufferw^[4], buffer^[leftlimit],j)
                                                  {shift work buffer to buffer}
        else
        begin
          dialoghead:=nil;
          new(dp);
          with dp^ do
          begin
            title:='Reduce amplitude of cut file to fit (halve)?';
            argtype:=_boolean;
            booleanresult:=true;
            next:=nil;
          end;
          add_dialogentry(dp,lastdp,dialoghead);
          new(dp);
          with dp^ do
          begin
            title:='Reduce amplitude of original to fit (halve)?';
            argtype:=_boolean;
            booleanresult:=true;
            next:=nil;
          end;
          add_dialogentry(dp,lastdp,dialoghead);
          new(dp);
          with dp^ do
          begin
            title:='If reducing original, reduce whole thing?';
            argtype:=_boolean;
            booleanresult:=true;
            next:=nil;
          end;
          add_dialogentry(dp,lastdp,dialoghead);
          settextstyle(defaultfont,horizdir,1);
          dialog_box(dialoghead,dialogbcolor,dialogcolor,true);
          reducecut:=dialoghead^.booleanresult;
          reduceoriginal:=dialoghead^.next^.booleanresult;
          reduceall:=dialoghead^.next^.next^.booleanresult;
          dispose(dialoghead);
          cutshift:=ord(reducecut);
          originalshift:=ord(reduceoriginal);
          settextstyle(defaultfont,horizdir,1);
          display_message('Calculating...',
                           dialogbcolor,dialogcolor,storagep,true);
          if reduceoriginal and reduceall then
          begin
            for i:=0 to leftlimit-1 do
              buffer^[i]:=buffer^[i] shr 1+64;
            for i:=leftlimit+j+1 to bufflength do
              buffer^[i]:=buffer^[i] shr 1+64;
          end;
          offset:=integer(128)-128 shr originalshift-128 shr cutshift;
          k:=leftlimit-4;
          for i:=leftlimit to leftlimit+j do
{$r-}        buffer^[i]:=integer(buffer^[i] shr originalshift)
                        +bufferw^[i-k] shr cutshift+offset;
{$ifdef debug}
{$r+}   { switch range checking off above means overrange produces distortion}
{$endif}
          display_message('Calculating...',
                           dialogbcolor,dialogcolor,storagep,false);
        end;
        set_bounds;
        Close(f);            {must do this incase another read (assign) later}
        workfile := fn;
      End
    Else
      Begin
        beep;
        default_sound_file:='';
        workfile:='';
        leftord := 0;
        rightord := bufflength;
        loopord := leftord;
        set_bounds;
        new(dp);
        dp^.next:=nil;
        dp^.title:='Sound file '+workfile+' not found';
        dp^.argtype:=_none;
        settextstyle(defaultfont,horizdir,1);
        dialog_box(dp,dialogbcolor,dialogcolor,true);
        dispose(dp);
      End;
  End;  {load_sound_file}



  Procedure select_system(c : Char);

    { selects speed params for xt, xt turbo, at, at turbo}

  Begin
    Case c Of
      'X' :
      Begin
              tconstant := round(1.19318e3/14);    {timer constant for 14KHz }
              systemname := 'XT';
            end;
      'T' :
      Begin
              tconstant := round(1.19318e3/22);     {timer constant for 22KHz }
              systemname := 'XT turbo';
            end;
      'A' :
      Begin
              tconstant := round(1.19318e3/30);    {timer constant for 30kHz }
              systemname := 'AT';
            end;
      'U' :
      Begin
              tconstant := round(1.19318e3/45);    {timer constant for 45kHz }
              systemname := 'AT turbo';
            end;
    End;                          {case}
    If c In ['X', 'T', 'A', 'U'] Then
      Begin
        incdef:=round(default_samplerate*(tconstant/1.1938e3)*256)+1;
        sysspeed:=incdef;   {incase pwm, this indicates system speed factor}

{$ifdef pwm}
    if c in ['X','T'] then
          tconstant:=round(1.19318e3/16)
        else
          tconstant := round(1.19318e3/20);
        incdef:=round(default_samplerate*(tconstant/1.1938e3)*256)+2;
{$endif pwm}

        increment := incdef;
        tune := increment;
        crotchet:=round(60.0/tconstant*100);
                                  {tinterval for a crotchet}
        modulus:=round(0.25*1.19318e6/crotchet/tconstant);
                             {set duration decrement rate for crotchet=.25 sec}
      End;
  End;  {select_system}

function get_daport(s:string):word;

{ sets d/a port from string}

var i,j:integer;

begin {get_daport}
    if (s='LPT2') or (s='lpt2') then
      get_daport:=lpt2
    else
      if (s='LPT3') or (s='lpt3') then
        get_daport:=lpt3
      else
        if (s='LPT1') or (s='lpt1') then
          get_daport:=lpt1
        else
        begin
          val(s,j,i);
          if i>0 then
          begin
            closegraph;
            writeln('Error in port address from ',cnffilename,' => ',s);
            halt;
          end;
          get_daport:=j;
        end;
end; {get_daport}


procedure display_status;

{ displays status and version info in a title box}

var dp,dialoghead,lastdialogentry:dialogentryp;

begin {display_status}
  dialoghead:=nil;
  if getmaxy>200 then
  begin
    new(dp);
    with dp^ do
    begin
      title:='  '+titlestring;
      argtype:=_none;
      add_dialogentry(dp,lastdialogentry,dialoghead);
    end;
  end;
  new(dp);
  with dp^ do
  begin
    title:='Current path:';
    argtype:=_string;
    nulvalid:=false;
    stringresult:=path;
    ssize:=length(titlestring)-11;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Current sound file:'+copy(bigemptystring,1,
                          length(titlestring)-length(workfile)-16)+workfile;
      argtype:=_none;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Instrument type:';
    argtype:=_string;
    nulvalid:=false;
    stringresult:=default_kbdmap;
    ssize:=6;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Sytem type:';
    argtype:=_string;
    nulvalid:=false;
    stringresult:=systemname;
    ssize:=8;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Key release:';
    argtype:=_boolean;
    booleanresult:=releasestate;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Loop mode:';
    argtype:=_boolean;
    booleanresult:=loop;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Auto timer:';
    argtype:=_boolean;
    booleanresult:=timer;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
{$ifdef sample}
  new(dp);
  with dp^ do
  begin
    title:='Trigger level:';
    argtype:=_integer;
    integerresult:=trigger;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  new(dp);
  with dp^ do
  begin
    title:='Sample rate:';
    argtype:=_integer;
    integerresult:=samplerate;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
{$endif}
  new(dp);
  with dp^ do
  begin
    title:='D/A port:';
    argtype:=_string;
    stringresult:=default_daport;
    nulvalid:=false;
    ssize:=4;
    add_dialogentry(dp,lastdialogentry,dialoghead);
  end;
  if getmaxy<300 then
  begin
    setusercharsize(14,10,100,101);
    settextstyle(smallfont,horizdir,usercharsize);
  end
  else
    settextstyle(defaultfont,horizdir,1);
  dialog_box(dialoghead,dialogbcolor,dialogcolor,true);
  dp:=dialoghead;
  if getmaxy>200 then
    dp:=dp^.next;
  path:=dp^.stringresult;
  dp:=dp^.next;
  dp:=dp^.next;
  default_kbdmap:=dp^.stringresult;
  dp:=dp^.next;
  systemname:=dp^.stringresult;
  while (systemname[1]=' ') and (length(systemname)>1) do
    delete(systemname,1,1);
  case upcase(systemname[1]) of
    'X': if (length(systemname)>4) and (systemname[5]<>' ') then
           select_system('T')
         else
           select_system('X');
    'A': if (length(systemname)>4) and (systemname[5]<>' ') then
           select_system('U')
         else
           select_system('A');
  end; {case}
  dp:=dp^.next;
  releasestate:=dp^.booleanresult;
  dp:=dp^.next;
  loop:=dp^.booleanresult;
  dp:=dp^.next;
  timer:=dp^.booleanresult;
{$ifdef sample}
  dp:=dp^.next;
  trigger:=dp^.integerresult;
  dp:=dp^.next;
  samplerate:=dp^.integerresult;
{$endif}
  dp:=dp^.next;
  default_daport:=dp^.stringresult;
  daout:=get_daport(default_daport);
  dispose_dialog(dialoghead);
end; {display_status}



  Procedure initialise;

    { initialise global variables etc}

  Var i,j:integer;

  Begin
    WriteLn;
    WriteLn('   ', titlestring);
    WriteLn;
    WriteLn;
    Assign(cnffile, cnffilename);
    {$i-} Reset(cnffile); {$i+}
    If IoResult <> 0 Then
      Begin
        WriteLn('Error opening configuration file ', cnffilename);
        Halt;
      End;

    songfilename:='';
    new(buffer);                  {create sound storage buffer}
    new(bufferw);                   {create buffer overflow space}
    new(dummy);                    {creat overflow area AFTER bufferw}
    ReadLn(cnffile, path);
    ReadLn(cnffile, default_sound_file);
    ReadLn(cnffile, default_system);
    ReadLn(cnffile, default_daport);
    ReadLn(cnffile, default_kbdmap);
    if path='' then
      path:='.';
    quickexit:=false;
    filesavail := 0;
    zoom:=false;
    goodbye:=false;
    loop := False;
    timer := False;
    song:=false;
    trigger := 200;                 {set trigger to reasonable level}
    select_system(Upcase(default_system));
    tinterval:=crotchet;        {set note duration to crotchet (if timer used)}
    copying := False;
    songspeed:=1.0;               {defauult song speed}
    kbdmode:=false;
    kbdflag := 0;
    keyval := 0;
    release:=true;
    releasestate := True;              {sensitive to key release}
    cutboxactive:=false;
    cutactive:=false;
    bufflen:=bufflength;

    graphdriver := detect;
    If (registerbgifont(@triplexfontproc) < 0) Or
    (registerbgifont(@smallfontproc) < 0) Then
      Begin
        WriteLn('Error loading font');
        Halt;
      End;
    If (registerbgidriver(@hercdriverproc) < 0) Or
    (registerbgidriver(@cgadriverproc) < 0) Or
    (registerbgidriver(@egavgadriverproc) < 0) Then
      Begin
        WriteLn('Error loading driver');
        Halt;
      End;

    initgraph(graphdriver, graphmode, 'c:\language\turbop4\grf');

    settextstyle(smallfont,horizdir,4);
    wavescale := 1 - Ord(getmaxy > 300) + 2;
    if getmaxy >200 then
      wavebottom := getmaxy-textheight(' ')*9
    else
      wavebottom := getmaxy-textheight(' ')*6;
    wavetop:=wavebottom-255 div wavescale;
    arrowlowy := wavebottom + 2;
    arrowhighy := wavebottom - 256 Div wavescale - arrowysize - 2;

    drawpoly(arrowpoints, uparrowshape); {draw up arrow}
    fillpoly(arrowpoints, uparrowshape); {fill   "     }
    GetMem(uparrowp, imagesize(0, 0, arrowxsize, arrowysize));
    getimage(0, 0, arrowxsize, arrowysize, uparrowp^); {save arrow image}
    drawpoly(arrowpoints, downarrowshape); {draw down arrow on the right}
    fillpoly(arrowpoints, downarrowshape);
    GetMem(downarrowp, imagesize(0, 0, arrowxsize, arrowysize));
    getimage(100, 0, 100 + arrowxsize, arrowysize, downarrowp^); {save image}

    cleardevice;
    initpointer;

    settextstyle(smallfont, horizdir, 4);
    settextjustify(lefttext, toptext);
    for j:=1 to noheadings do  {make storage for image under menu bars}
      for i:=2 to maxverticalbars do
        if menustructure[j].entry[i].selection<>inactive then
          GetMem(menustorage[j].entry[i],
                 imagesize(0,0,(getmaxx-cornersize*2) div noheadings,
                           round(textheight(' ')*1.5)-1));

    fill_background(screencolor,interleavefill,cornersize);
    display_title(titlestring,triplexfont,4,panelcolor,titlecolor);
    settextstyle(smallfont, horizdir, 4);
    settextjustify(lefttext, centertext);
    dirnamesperline := (getmaxx - cornersize * 2)
                       Div (dirnamefieldwidth * textwidth(' '));
    panel(getmaxx div 2,getmaxy div introyoff-textheight(' '),
          getmaxx-cornersize*2,textheight(' ')*8,panelcolor);
    settextstyle(defaultfont, horizdir, 1);
    selectcolor(black);

    daout:=get_daport(default_daport);

{$ifndef pwm}
    outtextxy(cornersize,getmaxy div introyoff,' D/A converter is on '
              +default_daport);
{$endif pwm}

    outtextxy(cornersize, getmaxy Div introyoff + textheight(' ') * 2,
              ' Sound files path is ' + path);

    If (default_kbdmap = 'guitar') Or (default_kbdmap = 'GUITAR') Then
      Begin
        default_kbdmap := 'guitar';
        kbdmap := kbdmapguitar;
      End;
    If default_kbdmap <> 'guitar' Then
      Begin
        default_kbdmap := 'piano ';
        kbdmap := kbdmappiano;
      End;

    outtextxy(cornersize, getmaxy Div introyoff + textheight(' ') * 4,
              ' Using keyboard map for ' + default_kbdmap);
    outtextxy(cornersize, getmaxy Div introyoff + textheight(' ') * 6,
              ' Reading default sound file ' + default_sound_file+'...');

    mousearrowon;
    cut_region(index(plotxoffset),index(getmaxx-plotxoffset)); {clear buffer}
    leftord:=0;
    rightord:=0;
    loopord:=0;
    load_sound_file(default_sound_file,index(plotxoffset),
                    index(getmaxx-plotxoffset),false);
    viewleft:=index(plotxoffset);
    viewright:=index(getmaxx-plotxoffset);
    samplerate:=default_samplerate;
    i:=0;
    display_status;
    mousearrowoff;

    settextstyle(defaultfont,horizdir,1);
    tuningcp:=nil;
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=0;
    cp^.y:=0;
    cp^.title:=#25;
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_figure;
    cp^.x:=textwidth('    ');
    cp^.y:=0;
    cp^.numpoints:=tuningshapepoints;
    cp^.polypoints:=@tuninglshape;
    cp^.fill:=true;
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('       ');
    cp^.y:=0;
    cp^.title:=#17;
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('          ');
    cp^.y:=0;
    cp^.title:=#16;
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_figure;
    cp^.x:=textwidth('             ');
    cp^.y:=0;
    cp^.numpoints:=tuningshapepoints;
    cp^.polypoints:=@tuningrshape;
    cp^.fill:=true;
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('                 ');
    cp^.y:=0;
    cp^.title:=#24;
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('                     ');
    cp^.y:=0;
    cp^.title:='Reset';
    add_clickboxentry(cp,lastcp,tuningcp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('      ');
    cp^.y:=-textheight(' ')*2;
    cp^.title:='Tuning';
    add_clickboxentry(cp,lastcp,tuningcp);

    timercp:=nil;
    new(cp);
    cp^.ttype:=_figure;
    cp^.x:=0;
    cp^.y:=0;
    cp^.numpoints:=tuningshapepoints;
    cp^.polypoints:=@tuninglshape;
    cp^.fill:=true;
    add_clickboxentry(cp,lastcp,timercp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('   ');
    cp^.y:=0;
    cp^.title:=#17;
    add_clickboxentry(cp,lastcp,timercp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('      ');
    cp^.y:=0;
    cp^.title:=#16;
    add_clickboxentry(cp,lastcp,timercp);
    new(cp);
    cp^.ttype:=_figure;
    cp^.x:=textwidth('         ');
    cp^.y:=0;
    cp^.numpoints:=tuningshapepoints;
    cp^.polypoints:=@tuningrshape;
    cp^.fill:=true;
    add_clickboxentry(cp,lastcp,timercp);
    new(cp);
    cp^.ttype:=_text;
    cp^.x:=textwidth('  ');
    cp^.y:=-textheight(' ')*2;
    cp^.title:=' Timer';
    add_clickboxentry(cp,lastcp,timercp);

  End;   {initialise}



  Procedure update_settings;

    { write settings on screen}

  Var str1,str2 : String;
    h : Integer;

  Begin
    settextstyle(smallfont,horizdir,4);
    h:=textheight(' ')*3;
    settextjustify(centertext, toptext);
    selectcolor(black);
    settextstyle(defaultfont, horizdir, 1);
    panel(getmaxx Div 2, h - Round(textheight(' ') * 0.25), getmaxx -cornersize*2,
          Round(textheight(' ') * 3.5),panelcolor);
    outtextxy(getmaxx div 2,h,'Current status:     ');

    str1:='';

{$ifdef sample}
    str(trigger,str2);
    str1:=str1 + ' Trigger:   '+str2;
{$endif}

    settextjustify(lefttext, toptext);
    outtextxy(cornersize, h +textheight(' '),str1+
             '   Path: ' + path +
             '    File: ' + workfile);

    If loop Then
      str1 := ' Loop mode:  on'
    Else
      str1 := ' Loop mode: off';
    If releasestate Then
      str1 := str1 + '   Key release:  on'
    Else
      str1 := str1 + '   Key release: off';
    If timer Then
      str1 := str1 + '   Auto timer:  on'
    Else
      str1 := str1 + '   Auto timer: off';

{$ifdef sample}
    str(samplerate,str2);
    str1:=str1+ '   Sample rate: '+str2+'kHz';
{$endif}

    outtextxy(cornersize, h + textheight(' ')*2, str1);
  End;    {update_settings}


procedure draw_wave;

{ draws wave box and wave form. clear indicates whether background should be
 cleared first}

  Var lasty, y,i : Integer;
    ratio : Real;

begin {draw_wave}
    ratio := (viewright-viewleft)/ (getmaxx - 2 * plotxoffset);
    selectfillstyle(solidfill, black);
    setlinestyle(solidln, 0, normwidth);
    selectcolor(waveboxcolor);
    bar(0, arrowlowy + arrowysize + 2, getmaxx, arrowhighy - 2);
    rectangle(plotxoffset, wavebottom + 1, getmaxx - plotxoffset,
              wavetop- 1);
    rectangle(0, arrowlowy + arrowysize + 2, getmaxx, arrowhighy - 2);
    selectcolor(wavecolor);
    moveto(plotxoffset,wavebottom-buffer^[viewleft] div wavescale);
    For i := 1 To getmaxx - plotxoffset*2 Do
      lineto(i+plotxoffset,
             wavebottom - buffer^[Round(i * ratio)+viewleft] Div wavescale);
    display_pointers(leftord,rightord,loopord,true,true,true);
{$ifdef pwm}
    scalewave;
{$endif {pwm}
end; {draw_wave}

  Procedure update_display;

    { refresh graphics screen}

  Begin
    fill_background(screencolor,interleavefill,cornersize);
    update_settings;
    draw_wave;
    draw_menu_headers;
    settextstyle(defaultfont,horizdir,1);
    draw_clicklist(tuningcp,cornersize,getmaxy-textheight(' ')*2,tuningbcolor,
                   tuningcolor);
    draw_clicklist(timercp,getmaxx-cornersize-textwidth('            '),
                   getmaxy-textheight(' ')*2,timerbcolor,
                   timercolor);
  End;  {update_display}


    PROCEDURE parsesong;

    { parse a Pianoman MUS file and save in song structure}

    var storagep:pointer;
        dp:dialogentryp;

    BEGIN {parsesongfile}

    songp := 1;
    while not eof(fsong) and (songp<=maxbeats) do
    begin
      read(fsong,anote);
      songarray[songp].note:=
       Exp(((anote.octave-3)*12+anote.note-20)* 0.057762265); {convert pianoman
                                                           note to keyboard note
                                                           ('Z'=>-12)}
      if anote.note=13 then
        songarray[songp].note:=-13;
      songarray[songp].duration:=
                            round(anote.duration/1700*162/sysspeed*crotchet);
                                {scale duration also. note sysspeed takes
                                account of system speed dependence of Pianoman.
                                1700 is a typical pianoman crotchet length for
                                my at turbo, 162 is sysspeed for an at turbo}
      inc(songp);
      if songp>maxbeats then
      begin
            new(dp);
            with dp^ do
            begin
              title:='Song too big - truncating';
              argtype:=_none;
              next:=nil;
            end;
            settextstyle(defaultfont,horizdir,1);
            dialog_box(dp,dialogbcolor,dialogcolor,true);
            dispose(dp);
      end;
    end;
    songend := Pred(songp);
    END;                      {parsesongfile}


    procedure loadsong;

    { loads and parses a song file}

    var storagep:pointer;
        dp:dialogentryp;

    begin
      pickfile('MUS',songfilename);
      mousearrowoff;
      display_message('Loading '+songfilename,
                       dialogbcolor,dialogcolor,storagep,true);
      if songfilename<>'' then
      begin
        if (songfilename[1]='\') or (songfilename[2]=':') then
          Assign(fsong, songfilename)
        else
          Assign(fsong, path+'\'+songfilename);
        {$i-}
        Reset(fsong);
        {$i+}
        IF IOResult = 0 THEN
        begin
          parsesong;
          Close(fsong);     {must do this incase another read (assign) later}
        end
        else
        begin
          beep;
            new(dp);
            with dp^ do
            begin
              title:='File not found ('+songfilename+')';
              argtype:=_none;
              next:=nil;
            end;
            settextstyle(defaultfont,horizdir,1);
            dialog_box(dp,dialogbcolor,dialogcolor,true);
            dispose(dp);
          songfilename:='';
        end;
      end;
      display_message('Loading '+songfilename,
                       dialogbcolor,dialogcolor,storagep,false);
      update_display;
      mousearrowon;
    end; {loadsong}

function arrow_selection:integer;

{ determines whether mouse is over a wave box arrow}

begin {arrow_selection}
if (mousex>=scaleord(leftord)-arrowxoff) and
   (mousex<=scaleord(leftord)-arrowxoff+arrowxsize) and
   (mousey>=arrowlowy) and (mousey<=arrowlowy+arrowysize) then
  arrow_selection:=1
else
if (mousex>=scaleord(rightord)-arrowxoff) and
   (mousex<=scaleord(rightord)-arrowxoff+arrowxsize) and
   (mousey>=arrowlowy) and (mousey<=arrowlowy+arrowysize) then
  arrow_selection:=2
else
if (mousex>=scaleord(loopord)-arrowxoff) and
   (mousex<=scaleord(loopord)-arrowxoff+arrowxsize) and
   (mousey>=arrowhighy) and (mousey<=arrowhighy+arrowysize) then
  arrow_selection:=3
else
  arrow_selection:=-1;
end; {arrow_selection}


procedure erase_cutbox;

{ erases cut box, restoring waveform}

var j:longint;

begin {erase_cutbox}
if cutboxactive then
begin
  for j:=wavetop-1 to wavebottom+1 do
    putpixel(scaleord(cutleft),j,getmaxcolor-getpixel(scaleord(cutleft),j));
  if cutleft<>cutright then
    for j:=wavetop-1 to wavebottom+1 do
      putpixel(scaleord(cutright),j,getmaxcolor-getpixel(scaleord(cutright),j));
  selectcolor(waveboxcolor);
  line(scaleord(cutleft)-1,wavetop-1,scaleord(cutright)+1,wavetop-1);
  line(scaleord(cutleft)-1,wavebottom+1,scaleord(cutright)+1,wavebottom+1);
end;
end; {erase_cutbox}


procedure draw_cutbox;

{ draws cut box}

var j:longint;

begin {draw_cutbox}
if cutboxactive then
begin
  for j:=wavetop-1 to wavebottom+1 do
    putpixel(scaleord(cutleft),j,getmaxcolor-getpixel(scaleord(cutleft),j));
  if cutleft<>cutright then
    for j:=wavetop-1 to wavebottom+1 do
      putpixel(scaleord(cutright),j,getmaxcolor-getpixel(scaleord(cutright),j));
  for j:=scaleord(cutleft)+1 to scaleord(cutright)-1 do
    if (getmaxcolor>1) or odd(j) then
    begin
      putpixel(j,wavetop-1,getmaxcolor-getpixel(j,wavetop-1));
      putpixel(j,wavebottom+1,getmaxcolor-getpixel(j,wavebottom+1));
    end;
end;
end; {draw_cutbox}

procedure activate_menu_options(state:boolean);

{ enable/disable menu options requiring cut box}

begin {activate_menu_options}
menustructure[3].entry[2].visible:=state; {cut}
menustructure[3].entry[3].visible:=state; {copy}
menustructure[3].entry[6].visible:=state; {mirror}
menustructure[3].entry[7].visible:=state; {envelope}
menustructure[3].entry[8].visible:=state; {clear}
if not zoom then
  menustructure[3].entry[9].visible:=state; {draw}
if cutactive and state then
begin
  menustructure[3].entry[4].visible:=true; {paste}
  menustructure[3].entry[5].visible:=true; {mix}
end
else
begin
  menustructure[3].entry[4].visible:=false;
  menustructure[3].entry[5].visible:=false;
end;
end; {activate_menu_options}


  Procedure mirror_data;

    { mirror sample data between pointers}

  Var temp : Byte;
    i, j : longInt;

  Begin
    settextstyle(defaultfont,horizdir,1);
    display_message('Calculating...',
                     dialogbcolor,dialogcolor,storagep,true);
    j:=cutright;
    For i := cutleft To (cutleft+cutright) shr 1 Do
      Begin
        temp := buffer^[i];        {temp}
        buffer^[i] := buffer^[j];
        buffer^[j] := temp;
        dec(j);
      End;
    display_message('Calculating...',
                     dialogbcolor,dialogcolor,storagep,false);
  End;    {mirror_data}


  Procedure scale_envelope;

    { scale sample data between points by an envelope formed by two end
    factors}

  Var j,i : longInt;
      k1 : Real;
      dp,dialoghead,lastdialogentry:dialogentryp;

  Begin
    dialoghead:=nil;
    new(dp);
    with dp^ do
    begin
      title:='Scale factor at left marker';
      argtype:=_real;
      decimalp:=2;
      realresult:=1;
      add_dialogentry(dp,lastdialogentry,dialoghead);
    end;
    new(dp);
    with dp^ do
    begin
      title:='Scale factor at right marker';
      argtype:=_real;
      decimalp:=2;
      realresult:=1;
      add_dialogentry(dp,lastdialogentry,dialoghead);
    end;
    settextstyle(defaultfont,horizdir,1);
    dialog_box(dialoghead,dialogbcolor,dialogcolor,true);
    If not ((dialoghead^.realresult = 1) and (dialoghead^.next^.realresult=1))
    Then
    Begin
      display_message('Calculating...',
                      dialogbcolor,dialogcolor,storagep,true);
      For i := scaleord(cutleft) To Pred(scaleord(cutright)) Do
      Begin
        k1 := (dialoghead^.next^.realresult - dialoghead^.realresult)
              / (scaleord(cutright)-scaleord(cutleft))
              * (i - scaleord(cutleft)+ plotxoffset) + dialoghead^.realresult;
        For j := index(i) to index(i+1)-1 do
          buffer^[j] := lo(Round((buffer^[j] - 128) * k1 + 128));
      End;
      display_message('Calculating...',
                      dialogbcolor,dialogcolor,storagep,false);
    End;
    dispose_dialog(dialoghead);
  End;   {scale_envelope}


  Procedure write_data(fn:string; leftlimit,rightlimit:longint);

    { write sample data to disk file}

  Var f : File;
    i,j : longint;
    dp:dialogentryp;

  Begin
        mousearrowoff;
        settextstyle(defaultfont,horizdir,1);
        display_message('Writing file, please wait...', dialogbcolor,
                        dialogcolor,storagep,true);
        If pos('.', fn) = 0 Then
          fn := fn + '.snd';
        if (fn[1]<>'\') and (fn[2]<>':') then
          Assign(f, path+'\'+fn)
        else
          assign(f,fn);
        {$i-}
        Rewrite(f);
        {$i+}
        If IoResult = 0 Then
          Begin
            Move(buffer^[leftlimit], bufferw^[4],rightlimit-leftlimit);
                           {shift up to make space for preamble}
            bufferw^[0] := lo(rightlimit-leftlimit);
            bufferw^[1] := hi(rightlimit-leftlimit);
            bufferw^[2] := lo(loopord-leftlimit);
            bufferw^[3] := hi(loopord-leftlimit);

            i:=0;
            For i := 1 to ((rightlimit-leftlimit) div 128)
                          div (blocksize div 128) do
              blockwrite(f,bufferw^[pred(i)*blocksize],blocksize shr 7);
            for j:=1 to ((rightlimit-leftlimit-1) div 128 +1)
                        mod (blocksize div 128) do
              BlockWrite(f, bufferw^[i*blocksize+pred(j)*128], 1);
            Close(f);
          End
        Else
          Begin
            beep;
            new(dp);
            dp^.next:=nil;
            dp^.title:='Disk write error';
            dp^.argtype:=_none;
            mousearrowon;
            dialog_box(dp,dialogbcolor,dialogcolor,true);
            mousearrowoff;
            dispose(dp);
          End;
        display_message('Writing file, please wait...', dialogbcolor,
                        dialogcolor,storagep,false);
        mousearrowon;
  End;    {write_data}