{************************************************************
 ***             MULTIPLE CURRENCIES                      ***
 ************************************************************}
{$I compflgs}
{This unit defines a multi-currency set of objects:

	- a currency item short code that defines a currency, eg pounds sterling
		or kenyan shilings, dollars, etc

	- a money object to be used for actually storing values, etc

	- an inputmonezy object for inputting above money object
{}

unit multcurr;

INTERFACE

uses tuiedit,files,scodes, forms, lstrings, devices, drivers, objects;

const
	mtValue = $01; {just plain value}
	mtRound = $02; {rounded off - no pence, etc}
	mtSymbol = $10; {with symbol}
	mtBlankZero = $20; {blank if zero}
	mtFull = mtSymbol + mtValue;

	siDefaultCurrency = 'DEFAULT CURRENCY';

type
	{====== CURRENCY SCODE TYPE ==========}
	PCurrencySCode = ^TCurrencySCode;
	TCurrencySCode = object(TSCodeItem)
		ID : byte; {also the symbol that appears on the input line}
		Abbr : string[4]; {standard abbreviation - ie Kshs, $, etc.}
		Trailing : boolean; {does the abbr trail or lead}
		NumDec : byte; {number of decimal places}

		constructor Init(const NCode, NDesc : string; NID : byte; NAbbr : string; NTrailing : boolean);
		constructor Load(var S : TDataStream);
		procedure Store(var S : TDataStream);
		function DisplayLine(Maxlen : integer) : string; virtual;
		procedure AddEditFields(P : PObjectEditBox);           virtual;
	end;

	function CreateCurrencySCode(Const NCode, NDesc : string) : PScodeItem;

type
	{======= MONEY OBJECT ================}
	PMoney = ^TMoney;
	TMoney = object(TObject)

		Value : longint;
{		Cents : byte; causing too many complications - not reqd yet anyway}
		CurrencyID : byte; {marks which currency}

		CurrencySCode : PCurrencySCode;

		constructor Init;

		procedure Clear;
		function Blank : boolean;

		function GetCurrency : PCurrencySCode;

		procedure ConvertTo(Currency : TCurrencySCode);

		{maths dealing with split cents/value}
		procedure SetTo(Money : TMoney);  {it's only double for kppms really, JIC strange values}
		procedure Add(Money : TMoney);
		procedure Subtract(Money : TMoney);
		procedure MultiplyBy(R : real);

		{-- Strings ---}
		function Text(mtType : byte) : string;

		{--- File Storing ---}
		procedure Store(var S : TStream);
		procedure Load(var S : TStream);

	end;

	{======= INPUT MONEY ==============}
	PInputMoney = ^TInputMoney;
	TInputMoney = object(TInputNum)
		CurrencyID : byte;
		BlankIfZero : boolean;
		constructor Init(Bounds : Trect);
		function Valid(Command : word) : boolean; virtual;
		procedure Draw; virtual;
		procedure HandleEvent(Var Event : TEvent); virtual;
		procedure GetData(var Rec); virtual;
		procedure SetData(var Rec); virtual;
		function DataSize : word; virtual;
	end;

	{===for forms - code to be replaced with money}
	PMOneyFormCode = ^TMoneyFormCode;
	TMoneyFormCode = object(TFormCode)
		Money : TMoney;
		constructor Init(NCOde : string; NMoney : TMoney);
		function Replace(const SubCode, Param : TFCodeStr; const FormCodes : PFormCodeCollection;
																													var LString : TLongString) : boolean; virtual;
	end;


	{==== Some extended Scodes =====}
	{Costed - extra money field}
	PCostedSCodeItem = ^TCostedSCodeItem;
	TCostedSCodeItem = object(TScodeItem)
		Cost : TMoney;
		constructor Init(const NCode, NDesc : string);
		constructor Load(var S : TDataStream);
		procedure Store(var S : TDataStream);
		function DisplayLine(Maxlen : integer) : string; virtual;
		function Print(Device : PDeviceStream; prType : word) : word; virtual;
		procedure AddEditFields(P : PObjectEditBox);           virtual;
	end;

	function CostedSCodeCreator(Const NCode, NDesc : string) : PScodeItem;


type
	{--- for automatically picking up money amount from scode selection line ---}
	PInputSCodePrice = ^TInputSCodePrice;
	TInputSCodePrice = object(TInputMoney)
{		scType : byte;{}
{		constructor Init(ABounds : TRect; AFieldLen : integer; ASource : pointer);{}
		procedure HandleEvent(var Event : TEvent); virtual;
	end;

{DO NOT DELETE ONCE USED!}
function GetCurrencyFromID(const ID : longint) : PCurrencySCode;
function GetIDfromCurrency(const Code : TSCode) : byte;


IMPLEMENTATION

uses kamsetup,tasks, help, tuimsgs, tui, global, views, minilib;

{*************************************
 ***         MONEY OBJECT          ***
 *************************************}

constructor TMoney.Init;
begin
	inherited Init;
	CurrencySCode := nil;
	Clear;
end;


procedure TMoney.Clear;
begin
{	Cents := 0;{}
	Value := 0;
	CurrencyID := GetIDFromCurrency(ProgramSetup.Get(siDefaultCurrency,'STE'));
	if CurrencyID=0 then
		ProgramWarning('Invalid default currency'#13'Cannot clear monetary value',hcNoContext);
end;

function TMoney.Blank;
begin if (Value = 0) {and (Cents=0){} then Blank := True else Blank := False; end;

procedure TMoney.SetTo;
begin
	CurrencyID := Money.CurrencyID;
{	Cents := Money.Cents;{}
	Value := Money.Value;
end;

procedure TMoney.Add;
begin
	if CurrencyID<>Money.CurrencyID then

		if Value<>0 then
			{cannnot add one currency to another - warning}
			ProgramWarning('Currency Mismatch'#13
											+'Cannot add '+Money.GetCurrency^.Abbr+' to '+GetCurrency^.Abbr,
											hcCurrencyMisMsg){}
		else
			{just-initialised/blank-value, so set currency}
			SetTo(Money)

	else begin
		Value := Value + Money.Value;
{		if Money.Value<0 then begin
			Money.Value := -Money.Value;
			Subtract(Money);
		end else begin
			Value := Value + Money.Value;
			Cents := Cents + Money.Cents;
			if Cents>100 then begin
				Cents := Cents - 100;
				Value := Value +1;
			end;
		end;{}
	end;
end;

procedure TMoney.Subtract;
begin
	if CurrencyID<>Money.CurrencyID then

		if Value<>0 then
			{cannot add one currency to another}
			ProgramWarning('Currency Mismatch'#13
											+'Cannot subtract '+Money.GetCurrency^.Abbr+' from '+GetCurrency^.Abbr,
											hcCurrencyMisMsg){}
		else
			{just-initalised, so set currency}
			SetTo(Money)

	else begin
		Value := Value - Money.Value;
{		if Money.Value<0 then begin
			{subtracting negative - just add - awkward messing with cents/etc o/wise}
{			Money.Value := -Money.Value;
			Add(Money);
		end else begin
			Value := Value - Money.Value;
			if -1>=(Cents-Money.Cents) then begin
				Cents := Cents +100 - Money.Cents;
				Value := Value -1;
			end else
				Cents := Cents - Money.Cents;
		end;{}
	end;
end;

procedure TMoney.MultiplyBy;
var C : longint;
begin
{	C := round(Cents * R) + round(frac(Value * R)*100);{}
	Value := round(Value * R);

{	Cents := C mod 100;
	Value := Value + (C div 100);{}
end;


procedure TMoney.ConvertTo;
begin
end;

function TMOney.GetCurrency : PCurrencySCode;
begin
	{do not dispose as pointer returned bz getcurrencyfromid is direct
		to collection entry}
	if (CurrencySCode=nil) or (CurrencySCode^.ID<>CurrencyID) then begin
		CurrencySCode := GetCurrencyFromID(CurrencyID);

		if CurrencySCode = nil then begin
{			ProgramWarning('TMoney.GetCurrency'#13#10'Could not locate currency ID'+N2Str(CurrencyID),hcNoContext);{}
			CurrencySCode := PCurrencySCode(GetSCode(scCurrency, ProgramSetup.Get(siDefaultCurrency,'STE')));
		end;
	end;

	GetCurrency := CurrencySCode;
end;


{---- Various output formats ----------}
function TMOney.Text;
var S : string[20];

begin
	if (mtType and mtBlankZero<>0) and (Value=0) {and (Cents=0){} then
		Text := ''
	else begin
		case (mtType and $0F) of
			mtRound : S := N2Str(Value div GetCurrency^.NumDec);
		else
			S := N2Str(Value div 100)+'.'+PadZero(N2Str(Unsign(Value) mod 100),2); {mtValue and default}
		end;

		if mtType and mtSymbol <>0 then
			if GetCurrency<>nil then
				if GetCurrency^.Trailing then
					S := S + GetCurrency^.Abbr
				else
					S := GetCurrency^.Abbr + S;

		Text := S;
	end;
end;


{--- File storing ----}
procedure TMoney.Store;
var Cents : byte;
begin
	S.Write(CurrencyID, 1);
	S.Write(Value, 4);
	S.Write(Cents, 1);
end;

procedure TMoney.Load;
var Cents : byte;
begin
	CurrencySCode := nil;
	S.Read(CurrencyID, 1);
	S.Read(Value, 4);
	S.Read(Cents, 1);
end;

{*********************************
 ***       FORM CODE           ***
 *********************************}
constructor TMoneyFormCode.Init;
begin
	inherited Init(NCode);
	Money.Init;
	Money.SetTo(NMoney);
end;

function TMoneyFOrmCode.Replace;
var WorkMOney : TMoney;
		Flags : byte;
begin
	Replace := True;

	WorkMoney.Init; WOrkMoney.SetTo(Money);

	Flags := mtValue;
	if pos('/R',Param)>0 then Flags := mtRound;

	if pos('/S',Param)>0 then Flags := Flags or mtSymbol;

	String2LS(Money.Text(Flags), LString);  {default}
end;

{*********************************
 ***       INPUT MONEY FIELD   ***
 *********************************}
constructor TInputMOney.Init(Bounds : Trect);
begin
	inherited Init(Bounds, 13); {10 digits for longint, +.00 for cents}
	DecPlaces := 2;
	BlankIfZero := False;
	CurrencyID := GetIDFromCurrency(ProgramSetup.Get(siDefaultCurrency,'STE'));
	if CurrencyID=0 then
		ProgramWarning('Could not locate currency '+ProgramSetup.Get(siDefaultCurrency,'STE'),hcInternalErrorMsg);{}
end;


function TInputMoney.Valid;
var L : longint;
		V : boolean;
		R : Real;
		CMoney : TMoney;

begin
	V := inherited Valid(COmmand);

	if V and DoValidFor(Command) then begin
		if Command<>cmForceLink then begin
			{right set}
			GetData(CMoney);
			SetData(CMoney);
			DrawView;
		end;
	end;

	Valid := V;
end;

procedure TInputMoney.HandleEvent(var Event : TEvent);
begin
	inherited HandleEvent(Event);

	if (Event.What = evKeyBoard) and (Event.KeyCode = kbSuperList) then begin
		{select currency}


		ClearEvent(Event);
	end;
end;


procedure TInputMoney.GetData(var Rec);
var Currency : PCurrencySCode;
begin
	TMoney(Rec).CurrencyID := CurrencyID;
	Currency := GetCurrencyFromID(CurrencyID); {safety check:}
	if Currency=nil then begin
		ProgramError('TinputMoney.GetData'#13'No Currency ID '+N2Str(CurrencyID)+' defined!',hcInternalErrorMsg);
		TMoney(rec).Init; {sets to default}
	end else
		TMoney(Rec).Value := round(S2Real(Data^)*Exp10(Currency^.NumDec));
{	if pos('.',Data^)>0 then
		TMoney(Rec).Cents := S2Num(Copy(Data^,pos('.',Data^)+1,256))
	else
		TMoney(Rec).Cents := 0;}
end;

procedure TInputMoney.SetData(var Rec);
var S : string;
begin
	CurrencyID := TMoney(Rec).CurrencyID;
	if BlankIfZero and TMoney(Rec).Blank then
		Data^ := ''
	else begin
		S := TMoney(Rec).Text(mtValue);
		if (length(S)<=(Size.X-2)) and (Maxlen>=Size.X-2) then {safety check for maxlen - should be larger}
			Data^ := PadSpaceL(S, Size.X-2) {if it will fit in display, then do so}
		else
			Data^ := copy(S,1,Maxlen); {otherwise just set, with safety length check}
	end;
end;

function TInputMoney.DataSize : word;
begin DataSize := Sizeof(TMoney); end;

procedure TInputMoney.Draw;
begin
	inherited Draw;
	if not BlankIfZero or (S2Real(Data^)<>0) then begin
		if GetState(sfDisabled) then
			{draw sign next to value}
			WriteChar(Size.X-length(delspaceL(Data^))-2, 0, char(CurrencyID),4,1)
		else
			{draw sign to left}
			writechar(0,0, char(CurrencyID), 4,1);   {Draws luminous green œ}
	end;
end;

{***************************************************************
 ***            CURRENCIES                                   ***
 ***************************************************************}
{DO NOT DELETE ONCE USED!}

function GetCurrencyFromID(const ID : longint) : PCurrencySCode;

	function TestID(TestItem : pointer) : boolean; far;
	begin
		if (PCurrencySCode(TestItem)^.ID = ID) then
			TestID := true
		else
			TestID := false;
	end;

begin
	SCodeCollection[scCurrency]^.LogOn;

	GetCurrencyFromID := PCurrencySCode(SCodeCollection[scCurrency]^.FirstThat(@TestID));

	SCodeCollection[scCurrency]^.LogOff;
end;

function GetIDFromCurrency(const Code : TSCode) : byte;
var P : pointer;
begin
	P := GetSCode(scCurrency, Code);
	if P<>nil then GetIDFromCurrency := PCurrencySCode(P)^.ID
	else GetIDFromCurrency := 0;
end;

constructor TCurrencySCode.Init;
begin
	inherited Init(NCode, NDesc);
	ID := NID;
	Abbr := NAbbr;
	Trailing := NTrailing;
	NumDec := 2;
end;


constructor TCurrencySCode.Load;
var Ver : byte;
begin
	S.Read(Ver,1);
	case Ver of
		6 : begin
			inherited Load(S);
			S.Read(ID, 1);
			S.Read(Abbr, 5);
			S.Read(Trailing, 1);
			S.Read(NumDec, 1);
		end;
	else
		S.Seek(S.GetPos-1);
		inherited Load(S);
		S.Read(ID, 1);
		S.Read(Abbr, 5);
		S.Read(Trailing, 1);
		NumDec := 2;
	end;
end;

procedure TCurrencySCode.Store;
var Ver : byte;
begin
	Ver := 6; S.Write(Ver,1);
	inherited Store(S);
	S.Write(ID, 1);
	S.Write(Abbr, 5);
	S.Write(Trailing,1);
	S.Write(NumDec, 1);
end;

function TCurrencySCode.DisplayLine;
var S : string;
begin
	S := inherited DisplayLine(Maxlen);
	DisplayLine := SetLength(S, 25)+Abbr+' '+char(ID);
end;

procedure TCurrencySCode.AddEditFields(P : PObjectEditBox);
var R : TRect;
begin
	inherited AddEditFields(P);
	P^.GrowTo(P^.Size.X, P^.Size.Y+3); {make room for below}
	P^.InsTitledField( 9,4, 3, 1, 'ID/Symb', New(PInputByte, init(R,3)));
	P^.InsTitledField( 9,5, 4, 1, 'Abbr', New(PInputELine, init(R,4)));
	P^.InsTitledField(22,5, 1, 1, 'Trlng', New(PinputBoolean, init(R)));
	P^.InsTitledField( 9,6, 2, 1, '# Dec', New(PInputByte, init(R, 2)));
end;


{*********************************
 *** SOME EXTENDED SCODE ITEMS ***
 *********************************}
{========= COSTED ==================}
constructor TCostedScodeItem.Init;
begin inherited Init(NCode, NDesc); Cost.Clear; end;

constructor TCostedSCodeItem.Load;
begin inherited Load(S);            Cost.Load(S);     end;

procedure TCostedSCodeItem.Store;
begin inherited Store(S);        		Cost.Store(S);		end;

function TCostedSCodeItem.DisplayLine;
var S : string;
begin
	S := inherited DisplayLine(Maxlen);
	DisplayLine := SetLength(S, Maxlen-length(Cost.Text(mtFull)))+Cost.Text(mtFull);
end;

procedure TCostedSCodeItem.AddEditFields(P : PObjectEditBox);
var R : TRect;
begin
{	P^.Insert(New(PSkipVMT, init));    {}
	inherited AddEditFields(P);
	P^.GrowTo(P^.Size.X, P^.Size.Y+1); {make room for below}
	P^.InsTitledField(9,4, 10, 1, 'Cost', New(PInputMoney, init(R)));
end;

function TCostedSCodeItem.Print;
begin
	Device^.writeln('    '+padspaceR(Code,3)
														+'  '+setlength(Description^,50)
														+'  '+padspaceL(Cost.Text(mtFull),9));
end;

	{********************************************************
	 ***         AUTOMATIC INPUT PRICE LINE               ***
	 ********************************************************}

{	constructor TinputSCodePrice.Init;
	begin
		inherited Init(ABounds, AFieldLen);
		{Sourcelink is assumed to be a scodeinputline}
{		PInputELine(ASource)^.SetTargetLink(@Self);{}
{	end;{}

	procedure TInputSCodePrice.HandleEvent;
	var Item : PSCodeItem;
			Money : Tmoney;
			SourceLine : PINputSCLine;
	begin
		if (Event.What = evCommand) and (Event.Command = cmUpdateFromLink) then begin
			SourceLine := PInputSCLine(Event.infoPtr);
			Item :=SCodeCollection[SourceLine^.scType]^.FindItem(SourceLine^.Data^);
			if Item <> nil then
				SetData(PCostedSCodeItem(Item)^.Cost)
			else begin
				Money.Init;
				SetData(Money);
			end;

			Draw;
			ForceLink;
	    ClearEvent(Event);
		end;
		inherited HandleEvent(Event);
	end;


{*********************************
 ***    REGISTRATION/ETC       ***
 *********************************}
function CostedSCodeCreator(const NCode, NDesc : string) : PScodeItem;
begin
	CostedSCodeCreator := New(PCostedScodeItem, init(NCode, NDesc));{}
end;

function CreateCurrencySCode(const NCode, NDesc : string) : PScodeItem;
begin
	CreateCurrencySCode := New(PCurrencySCode, init(NCode, NDesc,0,'',False));{}
end;

const
 RCurrencySCode : TStreamRec = (
	 ObjType : srCurrencySCode;
	 VmtLink : Ofs(TypeOf(TCurrencySCode)^);
	 Load : @TCurrencySCode.Load;
	 Store : @TCurrencySCode.Store
 );

 RCostedSCode : TStreamRec = (
	 ObjType : srCostedSCodeItem;
	 VmtLink : Ofs(TypeOf(TCostedSCodeItem)^);
	 Load : @TCostedSCodeItem.Load;
	 Store : @TCostedSCodeItem.Store
 );


begin
{$IFDEF fixit} writeln('Currencies...'); {$ENDIF}
	RegisterType(RCurrencySCode);
	RegisterType(RCostedSCode);

	RegisterSCodeType(scCurrency, 'CURRENCY.SC', 'Currencies', CreateCurrencySCode);

{$IFDEF fixit} writeln('..done'); {$ENDIF}
end.
