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.

///<summary>> Convert array of booleans to a pseudobinary integer. 
///Good for up to 12 bits.</summary>
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 <lars@fosdal.com>, December 1, 2010

interface
uses
  SysUtils, Generics.Collections;

type
  TSwitchProc = reference to procedure;
  TGenericSwitch<KeyType> = class(TObjectDictionary<KeyType, TSwitchProc>)
  private
    FTheElseCase: TSwitchProc;
    FTheTargetKey: KeyType;
    function AddSwitchCase(const name: KeyType; 
                           const value: TSwitchProc): TGenericSwitch<KeyType>;
    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<KeyType>;
    function ElseCase(const Action: TSwitchProc): TGenericSwitch<KeyType>;
    procedure EndCase;
    property Cases[const name:KeyType; const value:TSwitchProc]: TGenericSwitch<KeyType>
                  read AddSwitchCase; default;
  end;

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

implementation

{ TGenericSwitch<KeyType, TSwitchProc> }

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

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

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

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

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

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

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

{ TStringSwitch }

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


end.