Weird code snippet #1: Pseudobinary case statement

Curt Carpenter suggested a language addition for handing binary case logic.

That gave me this idea. Chalk it up as another weird code snippet from yours truly.

///> Convert array of booleans to a pseudobinary integer. 
///Good for up to 12 bits.

function BoolToInt(B: Array of Boolean):Integer;
var
x : Boolean;
begin
Result := 0;
for x in B
do begin
Result := Result * 10;
if x then Inc(Result);
end;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
ch : Char;
begin
ch := Lowercase(Char(Key));
case BoolToInt([ssShift in Shift, ssCtrl in Shift, ch='a', ch='x', ch='c', ch='v']) of
011000: SelectAll;
010100: Cut;
010010: Copy;
110010: Clone;
010001: Paste;
end;
end;

A slightly more tongue in cheek example:


procedure SexistTestLogic(const Cute, Funny, Smart: boolean);
begin
case BoolToInt([Cute, Funny, Smart]) of
000: Avoid;
001: Admire;
010,
011: Befriend;
100: Tolerate;
101: HandleWithCare;
110: Adore;
111: Marry;
end;
end;

A generic case for strings

Do you remember the discussion about a case statement for strings?

I got this flash idea after reading Jolyon Smith’s “The case for case[]”, and remembering a comment from Francisco Ruiz on Nick Hodges’ article on THTMLWriter which suggested using a default array property in a creative fashion.

Honestly, it is not really a true case statement, and it might not be as fast as an if then else, but here is how it looks when used. A bit ugly. but good fun 🙂

program TestGenericsSwitch;
{$apptype Console}
uses
  GenericsSwitch;
begin
TStringSwitch.CaseOf('chARLie')
['Any', procedure begin
Writeln('Definitively any case');
end]
['B', procedure begin
Writeln('B all you can B');
end]
['Charlie', procedure begin
Writeln('Checkpoint C');
end]
.ElseCase(procedure begin
Writeln('Else what?');
end)
.EndCase;
end.

And here is how it is implemented.

unit GenericsSwitch;

/// Written by Lars Fosdal , December 1, 2010

interface
uses
SysUtils, Generics.Collections;

type
TSwitchProc = reference to procedure;
TGenericSwitch = class(TObjectDictionary)
private
FTheElseCase: TSwitchProc;
FTheTargetKey: KeyType;
function AddSwitchCase(const name: KeyType;
const value: TSwitchProc): TGenericSwitch;
procedure SetTheElseCase(const Value: TSwitchProc);
procedure SetTheTargetKey(const Value: KeyType);
protected
function ValidateKey(Key:KeyType):KeyType; virtual;
property TheTargetKey:KeyType read FTheTargetKey write SetTheTargetKey;
property TheElseCase:TSwitchProc read FTheElseCase write SetTheElseCase;
public
class function CaseOf(const Key: KeyType):TGenericSwitch;
function ElseCase(const Action: TSwitchProc): TGenericSwitch;
procedure EndCase;
property Cases[const name:KeyType; const value:TSwitchProc]: TGenericSwitch
read AddSwitchCase; default;
end;

TStringSwitch = class(TGenericSwitch)
function ValidateKey(key:String):String; override;
end;

implementation

{ TGenericSwitch }

function TGenericSwitch.AddSwitchCase(const name: KeyType; const value: TSwitchProc): TGenericSwitch;
begin
Result := Self;
Add(ValidateKey(Name), Value);
end;

class function TGenericSwitch.CaseOf(const Key: KeyType): TGenericSwitch;
begin
Result := Create;
Result.TheTargetKey := Key;
end;

function TGenericSwitch.ElseCase(const Action: TSwitchProc): TGenericSwitch;
begin
Result := Self;
TheElseCase := Action;
end;

procedure TGenericSwitch.EndCase;
var
DoIt : TSwitchProc;
begin
if TryGetValue(TheTargetKey, DoIt)
then DoIt
else
if Assigned(TheElseCase)
then TheElseCase;
Destroy;
end;

procedure TGenericSwitch.SetTheElseCase(const Value: TSwitchProc);
begin
FTheElseCase := Value;
end;

procedure TGenericSwitch.SetTheTargetKey(const Value: KeyType);
begin
FTheTargetKey := ValidateKey(Value);
end;

function TGenericSwitch.ValidateKey(Key: KeyType):KeyType;
begin
Result := Key;
end;

{ TStringSwitch }

function TStringSwitch.ValidateKey(key: String): String;
begin
Result := LowerCase(Key);
end;


end.