(*
** Slashstone SoundFX Builder.
**
** This program is licensed under the terms of the MIT License. Read LICENSE
** or license.txt or the contents of the About box for more information.
*)
unit MainUnit;

{$mode objfpc}{$H+}

interface

uses
  Windows, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
  Menus, ComCtrls, EnvelopeControl, ExtCtrls, StdCtrls, Buttons, Spin;

type

  { TMain }
  
  TWaveformFunc = function(v: Real): Real;
  
  TMain = class(TForm)
    cbFreq: TComboBox;
    FreqPanel: TPanel;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    GroupBox3: TGroupBox;
    Label1: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    mHelpAbout: TMenuItem;
    mHelp: TMenuItem;
    mFileExportWAV: TMenuItem;
    mFileSave: TMenuItem;
    MenuItem2: TMenuItem;
    mEnvelopeResetVolume: TMenuItem;
    mEnvelopeResetFrequency: TMenuItem;
    mEnvelope: TMenuItem;
    mFileQuit: TMenuItem;
    mFileSaveAs: TMenuItem;
    mFileOpen: TMenuItem;
    mFileNew: TMenuItem;
    mFile: TMenuItem;
    rbDistsin: TRadioButton;
    Save: TSaveDialog;
    Open: TOpenDialog;
    SaveWAV: TSaveDialog;
    sbPlay: TSpeedButton;
    seUpHerz: TSpinEdit;
    tbGlobalVol: TTrackBar;
    tbSquarization: TTrackBar;
    tbDelay: TTrackBar;
    tbDelayAmp: TTrackBar;
    tbPurify: TTrackBar;
    WaveImg: TPaintBox;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    rbSquare: TRadioButton;
    rbSine: TRadioButton;
    seLength: TSpinEdit;
    VolPanel: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure WaveImgPaint(Sender: TObject);
    procedure cbFreqChange(Sender: TObject);
    procedure mEnvelopeResetFrequencyClick(Sender: TObject);
    procedure mEnvelopeResetVolumeClick(Sender: TObject);
    procedure mFileExportWAVClick(Sender: TObject);
    procedure mFileNewClick(Sender: TObject);
    procedure mFileOpenClick(Sender: TObject);
    procedure mFileQuitClick(Sender: TObject);
    procedure mFileSaveAsClick(Sender: TObject);
    procedure mFileSaveClick(Sender: TObject);
    procedure mHelpAboutClick(Sender: TObject);
    procedure rbDistsinChange(Sender: TObject);
    procedure rbSineClick(Sender: TObject);
    procedure rbSquareClick(Sender: TObject);
    procedure sbPlayClick(Sender: TObject);
    procedure seLengthChange(Sender: TObject);
    procedure tbDelayAmpChange(Sender: TObject);
    procedure tbDelayChange(Sender: TObject);
    procedure tbGlobalVolChange(Sender: TObject);
    procedure tbPurifyChange(Sender: TObject);
    procedure tbSquarizationChange(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
    FileName: String;
    Freq: Integer;
    FreqEnv, VolEnv: TEnvelope;
    Wave: array of Real;
    WaveLength: Integer;
    PlayBuffer: array of Short;
    UpHerz: Real;
    WaveFunc: TWaveformFunc;
    WaveFuncCode: Integer;
    GlobalVol, Squarization, Delay, DelayAmp, Purify: Real;
    
    procedure EnvelopePositionChanged(Sender: TObject);
    procedure EnvelopeModified(Sender: TObject);
    procedure SetWaveLength(NewLength: Integer);
    procedure GenerateWave;
    procedure DrawWave;
  end;

var
  Main: TMain;

implementation

uses
  AboutBoxUnit;

{ TMain }

procedure InitPlayBuff; cdecl; external 'playbuff.dll';
procedure ShutdownPlayBuff; cdecl; external 'playbuff.dll';
procedure PlaySoundBuffer(Buffer: PShort; Length, Freq: Integer); cdecl; external 'playbuff.dll';

function SineFunc(v: Real): Real;
begin
  SineFunc:=Sin(v);
end;

function DistsineFunc(v: Real): Real;
begin
  DistsineFunc:=Sin(v)+sin(v*2)/2;
end;

function SquareFunc(v: Real): Real;
begin
  if Sin(v) > 0 then
    SquareFunc:=1
  else
    SquareFunc:=-1;
end;

procedure TMain.EnvelopePositionChanged(Sender: TObject);
begin
  if Sender=FreqEnv then
    VolEnv.Position:=FreqEnv.Position
  else
    FreqEnv.Position:=VolEnv.Position;
  DrawWave;
end;

procedure TMain.EnvelopeModified(Sender: TObject);
begin
  GenerateWave;
end;

procedure TMain.SetWaveLength(NewLength: Integer);
begin
  WaveLength:=NewLength*Freq div 1000;
  SetLength(Wave, WaveLength);
end;

procedure TMain.GenerateWave;
var
  F, V: Real;
  i, Fp, Vp, DP: Integer;
  Fnpp, Vnpp: Integer;
  Fs, Vs: Real;
  SP: Real;
  Len: Real;
  T, Sample: Real;
begin
  Fp:=0;
  Vp:=0;
  
  F:=FreqEnv.Point[0].y*UpHerz;
  V:=VolEnv.Point[0].y;
  Len:=Int((FreqEnv.Point[1].x - FreqEnv.Point[0].x)*WaveLength);
  if Len <= 0 then Len:=1;
  Fs:=(FreqEnv.Point[1].y*UpHerz - FreqEnv.Point[0].y*UpHerz);
  Fs:=Fs/Len;
  Len:=Int((VolEnv.Point[1].x - VolEnv.Point[0].x)*WaveLength);
  if Len <= 0 then Len:=1;
  Vs:=(VolEnv.Point[1].y - VolEnv.Point[0].y);
  Vs:=Vs/Len;
  Fnpp:=Trunc(FreqEnv.Point[1].x*WaveLength);
  Vnpp:=Trunc(VolEnv.Point[1].x*WaveLength);

  T:=0;
  for i:=0 to WaveLength-1 do begin
    if (i=Fnpp) and (Fp < Length(FreqEnv.Point) - 1) then begin
      Inc(Fp);
      F:=FreqEnv.Point[Fp].y*UpHerz;
      Len:=Int((FreqEnv.Point[Fp + 1].x - FreqEnv.Point[Fp].x)*WaveLength);
      if Len <= 0 then Len:=1;
      Fs:=(FreqEnv.Point[Fp + 1].y*UpHerz -
        FreqEnv.Point[Fp].y*UpHerz);
      Fs:=Fs/Len;
      Fnpp:=Trunc(FreqEnv.Point[Fp + 1].x*WaveLength);
    end;
    if (i=Vnpp) and (Vp < Length(VolEnv.Point) - 1) then begin
      Inc(Vp);
      V:=VolEnv.Point[Vp].y;
      Len:=Int((VolEnv.Point[Vp + 1].x - VolEnv.Point[Vp].x)*WaveLength);
      if Len <= 0 then Len:=1;
      Vs:=(VolEnv.Point[Vp + 1].y - VolEnv.Point[Vp].y);
      Vs:=Vs/Len;
      Vnpp:=Trunc(VolEnv.Point[Vp + 1].x*WaveLength);
    end;

    SP:=WaveFunc(T);
    T:=T + (F*Freq/22050)*Pi/Freq;
    Sample:=SP;

    if Squarization <> 0 then begin
      Sample:=Sample*(1-Squarization) + SquareFunc(T)*Squarization;
    end;
    
    if (Delay <> 0) and (DelayAmp <> 0) then begin
      DP:=i-Trunc(Delay*WaveLength);
      if DP >= 0 then Sample:=Sample + Wave[DP]*DelayAmp;
    end;
    
    if Purify <> 0 then begin
      Sample:=(Sample + SineFunc(T)*Purify)/(1 + Purify);
    end;

    Sample:=Sample*V*GlobalVol;

    if Sample > 0.95 then
      Sample:=0.95
    else if Sample < -0.95 then
      Sample:=-0.95;
    
    Wave[i]:=Sample;

    F:=F + Fs;
    V:=V + Vs;
  end;
  DrawWave;
end;

procedure TMain.DrawWave;
var
  i, x, y: Integer;
  BackBuffer: TBitmap;
begin
  BackBuffer:=TBitmap.Create;
  BackBuffer.Width:=WaveImg.Width;
  BackBuffer.Height:=WaveImg.Height;
  with BackBuffer.Canvas do begin
    Brush.Color:=clBlack;
    Rectangle(-1, -1, 244, 60);
    Pen.Color:=$00004000;
    x:=Trunc(243*VolEnv.Position);
    Line(x, 0, x, 60);
    Pen.Color:=clGreen;
    if Length(Wave) > 0 then begin
      for i:=0 to 243 do begin
        y:=Trunc(Wave[WaveLength*i div 244]*30);
        if i = 0 then
          MoveTo(i, WaveImg.Height div 2 - y)
        else
          LineTo(i, WaveImg.Height div 2 - y)
      end;
    end;
    Pen.Color:=$00005000;
    Line(0, WaveImg.Height div 2, 244, WaveImg.Height div 2);
  end;
  WaveImg.Canvas.Draw(0, 0, BackBuffer);
  BackBuffer.Free;
end;

procedure TMain.FormShow(Sender: TObject);
begin
  Top:=Top-50;
end;

procedure TMain.WaveImgPaint(Sender: TObject);
begin
  DrawWave;
end;

procedure TMain.cbFreqChange(Sender: TObject);
begin
  Freq:=22050;
  SetWaveLength(seLength.Value);
  GenerateWave;
end;

procedure TMain.mEnvelopeResetFrequencyClick(Sender: TObject);
begin
  if MessageBox(Handle, 'Are you sure?', 'Reset Frequency Envelope',
    MB_ICONQUESTION or MB_YESNO) = IDNO then Exit;
  FreqEnv.Reset;
end;

procedure TMain.mEnvelopeResetVolumeClick(Sender: TObject);
begin
  if MessageBox(Handle, 'Are you sure?', 'Reset Volume Envelope',
    MB_ICONQUESTION or MB_YESNO) = IDNO then Exit;
  VolEnv.Reset;
end;

procedure TMain.mFileExportWAVClick(Sender: TObject);
var
  f: File;
  ID: array [0..3] of Char;
  i: Integer;
  Sample: Short;
  
  procedure WriteChunkHeader(Chnk: String; Size: Integer);
  var
    CId: array [0..3] of Char;
  begin
    CId[0]:=Chnk[1];
    CId[1]:=Chnk[2];
    CId[2]:=Chnk[3];
    CId[3]:=Chnk[4];
    BlockWrite(f, CId, 4);
    BlockWrite(f, Size, 4);
  end;
  
  procedure WriteInt(I: Integer);
  begin
    BlockWrite(f, I, 4);
  end;

  procedure WriteShort(S: Short);
  begin
    BlockWrite(f, S, 2);
  end;
  
begin
  SaveWAV.FileName:=ExtractFileName(FileName);
  if Pos('.', SaveWAV.FileName)=0 then
    SaveWAV.FileName:=SaveWAV.FileName+'.wav'
  else
    SaveWAV.FileName:=Copy(SaveWAV.FileName, 1, Pos('.', SaveWAV.FileName) - 1)+
      '.wav';
  if SaveWAV.Execute then begin
    GenerateWave;
  
    AssignFile(f, SaveWAV.FileName);
    {$I- }
    Rewrite(f, 1);
    {$I+ }
    if IOResult <> 0 then begin
      ShowMessage('Cannot export WAVE file '+SaveWAV.FileName);
      Exit;
    end;
    
    { RIFF Header }
    WriteChunkHeader('RIFF', 0); // update the size later //
    ID:='WAVE';
    BlockWrite(f, ID, 4);
    
    { WAVE - fmt }
    WriteChunkHeader('fmt ', 16);
    WriteShort(1);                  // PCM
    WriteShort(1);                  // 1 channel (Mono)
    WriteInt(22050);                // Sample rate
    WriteInt(44100);                // Byte rate (samrate*channels*byte/sam)
    WriteShort(2);                  // Block align (bytes per frame)
    WriteShort(16);                 // Bits per sample
    
    { WAVE - data }
    WriteChunkHeader('data', WaveLength*2);
    for i:=0 to WaveLength-1 do begin
      Sample:=Trunc(Wave[i]*32760);
      BlockWrite(f, Sample, 2);
    end;
    
    { Fix size }
    i:=FileSize(f)-8;
    Seek(f, 4);
    BlockWrite(f, i, 4);

    CloseFile(f);
  end;
end;

procedure TMain.mFileNewClick(Sender: TObject);
begin
  FileName:='';
  Caption:='Slashstone SoundFX Builder';
  try
    FreqEnv.Reset;
    VolEnv.Reset;
  except
  end;
  
  seLength.Value:=220;
  cbFreq.ItemIndex:=0;
  seUpHerz.Value:=4000;
  rbSine.Checked:=True;
  tbGlobalVol.Position:=500;
  tbSquarization.Position:=0;
  tbDelay.Position:=0;
  tbDelayAmp.Position:=0;
  tbPurify.Position:=0;
  
  GlobalVol:=0.5;
  Squarization:=0;
  Delay:=0;
  DelayAmp:=0;
  Purify:=0;
  Freq:=22050;
  SetWaveLength(220);
  UpHerz:=4000;
  WaveFunc:=@SineFunc;
  WaveFuncCode:=0;
  GenerateWave;
end;

procedure TMain.mFileOpenClick(Sender: TObject);
var
  f: File;
  ID: array [0..3] of Char;
  Version: Byte;
  i: Integer;
  
  procedure LoadEnvelope(E: TEnvelope);
  var
    i: Integer;
  begin
    BlockRead(f, i, SizeOf(Integer));
    SetLength(E.Point, i);
    for i:=0 to Length(E.Point)-1 do begin
      BlockRead(f, E.Point[i].x, SizeOf(Real));
      BlockRead(f, E.Point[i].y, SizeOf(Real));
    end;
  end;

begin
  if Open.Execute then begin
    AssignFile(f, Open.FileName);
    {$I- }
    Reset(f, 1);
    {$I+ }
    if IOResult <> 0 then begin
      ShowMessage('Cannot open '+Open.FileName);
      Exit;
    end;
    BlockRead(f, ID, 4);
    if ID <> 'SSFX' then begin
      ShowMessage('This is not a Slashstone SoundFX Builder file');
      Exit;
    end;
    BlockRead(f, Version, 1);
    if Version <> 1 then begin
      ShowMessage('Unknown version '+IntToStr(Version));
      Exit;
    end;
    
    mFileNewClick(nil);

    BlockRead(f, GlobalVol, SizeOf(Real));
    BlockRead(f, Squarization, SizeOf(Real));
    BlockRead(f, Delay, SizeOf(Real));
    BlockRead(f, DelayAmp, SizeOf(Real));
    BlockRead(f, Purify, SizeOf(Real));
    BlockRead(f, WaveFuncCode, SizeOf(Integer));
    BlockRead(f, i, SizeOf(Integer));
    seLength.Value:=i;
    BlockRead(f, i, SizeOf(Integer));
    seUpHerz.Value:=i;
    UpHerz:=i;

    LoadEnvelope(FreqEnv);
    LoadEnvelope(VolEnv);

    CloseFile(f);
    
    FileName:=Open.FileName;
    Caption:='Slashstone SoundFX Builder - ' + ExtractFileName(FileName);
    
    tbGlobalVol.Position:=Trunc(GlobalVol*1000);
    tbSquarization.Position:=Trunc(Squarization*1000);
    tbDelay.Position:=Trunc(Delay*1000);
    tbDelayAmp.Position:=Trunc(DelayAmp*1000);
    tbPurify.Position:=Trunc(Purify*1000);
    case WaveFuncCode of
      0: rbSine.Checked:=True;
      1: rbDistsin.Checked:=True;
      2: rbSquare.Checked:=True;
    end;

    SetWaveLength(seLength.Value);
    GenerateWave;
    FreqEnv.Draw;
    VolEnv.Draw;
  end;
end;

procedure TMain.mFileQuitClick(Sender: TObject);
begin
  Close;
end;

procedure TMain.mFileSaveAsClick(Sender: TObject);
begin
  if Save.Execute then begin
    FileName:=Save.FileName;
    Caption:='Slashstone SoundFX Builder - ' + ExtractFileName(FileName);
    mFileSaveClick(Sender);
  end;
end;

procedure TMain.mFileSaveClick(Sender: TObject);
var
  f: File;
  ID: array [0..3] of Char;
  Version: Byte;
  i: Integer;
  
  procedure SaveEnvelope(E: TEnvelope);
  var
    i: Integer;
  begin
    i:=Length(E.Point);
    BlockWrite(f, i, SizeOf(Integer));
    for i:=0 to Length(E.Point)-1 do begin
      BlockWrite(f, E.Point[i].x, SizeOf(Real));
      BlockWrite(f, E.Point[i].y, SizeOf(Real));
    end;
  end;
  
begin
  if FileName='' then begin
    mFileSaveAsClick(Sender);
    Exit;
  end;
  ID:='SSFX';
  Version:=1;
  AssignFile(f, FileName);
  {$I- }
  Rewrite(f, 1);
  {$I+ }
  if IOResult <> 0 then begin
    ShowMessage('Cannot save '+FileName);
    Exit;
  end;
  BlockWrite(f, ID, 4);
  BlockWrite(f, Version, 1);
  BlockWrite(f, GlobalVol, SizeOf(Real));
  BlockWrite(f, Squarization, SizeOf(Real));
  BlockWrite(f, Delay, SizeOf(Real));
  BlockWrite(f, DelayAmp, SizeOf(Real));
  BlockWrite(f, Purify, SizeOf(Real));
  BlockWrite(f, WaveFuncCode, SizeOf(Integer));
  i:=seLength.Value;
  BlockWrite(f, i, SizeOf(Integer));
  i:=seUpHerz.Value;
  BlockWrite(f, i, SizeOf(Integer));
  
  SaveEnvelope(FreqEnv);
  SaveEnvelope(VolEnv);

  CloseFile(f);
end;

procedure TMain.mHelpAboutClick(Sender: TObject);
begin
  AboutBox.ShowModal;
end;

procedure TMain.rbDistsinChange(Sender: TObject);
begin
  WaveFunc:=@DistsineFunc;
  WaveFuncCode:=1;
  GenerateWave;
end;

procedure TMain.rbSineClick(Sender: TObject);
begin
  WaveFunc:=@SineFunc;
  WaveFuncCode:=0;
  GenerateWave;
end;

procedure TMain.rbSquareClick(Sender: TObject);
begin
  WaveFunc:=@SquareFunc;
  WaveFuncCode:=2;
  GenerateWave;
end;

procedure TMain.sbPlayClick(Sender: TObject);
var
  i: Integer;
begin
  SetLength(PlayBuffer, WaveLength);
  for i:=0 to WaveLength-1 do PlayBuffer[i]:=Trunc(Wave[i]*32760);
  PlaySoundBuffer(@PlayBuffer[0], WaveLength, Freq);
end;

procedure TMain.seLengthChange(Sender: TObject);
begin
  SetWaveLength(seLength.Value);
  GenerateWave;
  UpHerz:=seUpHerz.Value;
end;

procedure TMain.tbDelayAmpChange(Sender: TObject);
begin
  DelayAmp:=tbDelayAmp.Position/1000;
  GenerateWave;
end;

procedure TMain.tbDelayChange(Sender: TObject);
begin
  Delay:=tbDelay.Position/1000;
  GenerateWave;
end;

procedure TMain.tbGlobalVolChange(Sender: TObject);
begin
  GlobalVol:=tbGlobalVol.Position/1000;
  GenerateWave;
end;

procedure TMain.tbPurifyChange(Sender: TObject);
begin
  Purify:=tbPurify.Position/1000;
  GenerateWave;
end;

procedure TMain.tbSquarizationChange(Sender: TObject);
begin
  Squarization:=tbSquarization.Position/1000;
  GenerateWave;
end;

procedure TMain.FormCreate(Sender: TObject);
begin
  InitPlayBuff;

  FreqEnv:=TEnvelope.Create(FreqPanel);
  FreqPanel.InsertControl(FreqEnv);
  FreqEnv.Align:=alClient;

  VolEnv:=TEnvelope.Create(VolPanel);
  VolPanel.InsertControl(VolEnv);
  VolEnv.Align:=alClient;
  
  FreqEnv.OnPositionChanged:=@EnvelopePositionChanged;
  FreqEnv.OnEnvelopeModified:=@EnvelopeModified;
  VolEnv.OnPositionChanged:=@EnvelopePositionChanged;
  VolEnv.OnEnvelopeModified:=@EnvelopeModified;

  mFileNewClick(nil);
end;

procedure TMain.FormDestroy(Sender: TObject);
begin
  ShutdownPlayBuff;
end;

initialization
  {$I mainunit.lrs}

end.

