Skip to content

Instantly share code, notes, and snippets.

Last active February 28, 2021 18:11
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
What would you like to do?
Toy demo program illustrating the use of a multi-dimensional associative array (hash) as a sparse lookup table.
#!/usr/bin/env perl
# File:
# Abstract: Demonstrate sparse lookup table as multi-dimensional hash.
# Usage: ./car-options [keyword ...]
# Author:
# License: Perl Artistic
# See:
# Beware:
my $HELP_TEXT = <<'EOM';
This program is designed to demonstrate a technique where a sparse
lookup table can be easily represented using a multi-dimensional
'associative array'. This particular implementation uses Perl hash
tables, but the general technique should be applicable to other
programming languages with associative array support.
The motivation for the demo is validating selected options for a
particular make and model of automobile with five trim lines. The
allowed combination of options can be represented as:
--------- ------------- --------------- -------------- ------
Trim Interior Wheels Transmission Cruise
--------- ------------- --------------- -------------- ------
Base cloth steel|alloy manual n/a
Premium cloth|leather alloy manual|auto std
Sport sport-cloth 18" black-alloy 6-speed manual opt
Limited cloth|leather alloy manual|auto std
Touring leather 18" alloy auto std
--------- ------------- --------------- -------------- ------
For example, the only option available for the 'Base' trim line is
alloy wheels instead of the stock steel wheels. Likewise the only
option for the 'Sport' trim is cruise-control, but the 'Sport' trim
comes with exclusive two-tone seats, special alloy wheels, and a
special manual transmission, none of which are available for any other
trim lines. In contrast the 'Premium' can be had with a cloth or
leather interior and a choice of a manual or automatic transmission.
The interactive demonstration allows you to enter a trim line,
followed by the desired interior, wheels, transmission, and if cruise
control is wanted. If that set of options is allowed, the 'Bundle ID'
is displayed, otherwise an exception is thrown. Enter at least the
trim line keyword (or its abbreviation) on the command line. Any
missing options will be prompted for.
$ ./ b
Enter desired options for the BASE trim
Interior? (cloth leather sport): c
Wheels? (steel alloy sport touring): st
Transmission? (manual auto sport): m
Cruise Control? (0 1): 0
Given: Trim: base
Interior: cloth
Wheels: steel
Transmission: manual
Cruise Control: 0
Selected Bundle: B1
The following full command line would be equivalent to the above:
$ ./ b c st m 0
Note that invalid keywords may be entered for testing the lookup
validation, and ambiguous abbreviations are accepted as-is.
use warnings;
use strict;
use Text::Abbrev; # For command line abbreviations
use Carp; # For logic error stack trace.
# The following code segment demonstrates the technique being
# illustrated. An exception is thrown if an invalid option
# combination is proved or an expected keyword is misspelled.
# Set of valid bundle combinations. |
my %bundle = ();
# Trim Interior Wheels Trannie Cruise Bundle
# --------- --------- --------- -------- ------ ------
$bundle {base} {cloth} {steel} {manual} {0} = 'B1';
$bundle {base} {cloth} {alloy} {manual} {0} = 'B2';
$bundle {premium} {cloth} {alloy} {manual} {0} = 'P1';
$bundle {premium} {leather} {alloy} {manual} {0} = 'P2';
$bundle {premium} {cloth} {alloy} {auto} {0} = 'P3';
$bundle {premium} {leather} {alloy} {auto} {0} = 'P4';
$bundle {sport} {sport} {sport} {sport} {0} = 'S1';
$bundle {sport} {sport} {sport} {sport} {1} = 'S2';
$bundle {limited} {cloth} {alloy} {manual} {1} = 'L1';
$bundle {limited} {leather} {alloy} {manual} {1} = 'L2';
$bundle {limited} {cloth} {alloy} {auto} {1} = 'L3';
$bundle {limited} {leather} {alloy} {auto} {1} = 'L4';
$bundle {touring} {leather} {touring} {auto} {1} = 'T1';
# Supports validation of keyword sets. |
$bundle {ANY} {cloth} {ANY} {ANY} {ANY} = 1;
$bundle {ANY} {sport} {ANY} {ANY} {ANY} = 1;
$bundle {ANY} {leather} {ANY} {ANY} {ANY} = 1;
$bundle {ANY} {ANY} {steel} {ANY} {ANY} = 1;
$bundle {ANY} {ANY} {alloy} {ANY} {ANY} = 1;
$bundle {ANY} {ANY} {sport} {ANY} {ANY} = 1;
$bundle {ANY} {ANY} {touring} {ANY} {ANY} = 1;
$bundle {ANY} {ANY} {ANY} {manual} {ANY} = 1;
$bundle {ANY} {ANY} {ANY} {sport} {ANY} = 1;
$bundle {ANY} {ANY} {ANY} {auto} {ANY} = 1;
$bundle {ANY} {ANY} {ANY} {ANY} {0} = 1;
$bundle {ANY} {ANY} {ANY} {ANY} {1} = 1;
# Function to validate option mix and |
# return the Trim's Bundle code. |
sub fail ( $ $ ) { confess("Invalid ", uc($_[0]), " keyword: '$_[1]'\n_") }
sub bundleLookup ( $ $ $ $ $ )
foreach my $param (@_) # this modifies contents of array @_
confess("Required parameter is undefined") if (not defined($param));
$param = lc($param);
my($trim, $seats, $wheels, $trans, $cruise) = @_;
confess("Not a recognized trim line: $trim\n_")
if (not exists($bundle{$trim}));
if (exists($bundle{$trim}{$seats}{$wheels}{$trans}{$cruise}));
# Uh, oh -- still here. Was there a bad keyword?
fail('seats',$seats) if (not exists($bundle{ANY}{$seats}{ANY}{ANY}{ANY}));
fail('wheels',$wheels) if (not exists($bundle{ANY}{ANY}{$wheels}{ANY}{ANY}));
fail('trans',$trans) if (not exists($bundle{ANY}{ANY}{ANY}{$trans}{ANY}));
fail('cruise',$cruise) if (not exists($bundle{ANY}{ANY}{ANY}{ANY}{$cruise}));
# Must have been an invalid bundle.
confess("Invalid option combination for trim line: $trim\n_");
# The following code is used to support the interactive testing of
# bundleLookup() function from the command line. The lookup table
# keywords sets are defined here only to allow the convenience of
# abbreviation while testing and are not used to validate the input.
# The user can (and is encouraged) to enter invalid trim and option
# data for testing the bundleLookup() response.
my @trimKeyWord = qw(base premium sport limited touring);
my @interiorKeyWord = qw(cloth leather sport);
my @wheelsKeyWord = qw(steel alloy sport touring);
my @trannieKeyWord = qw(manual auto sport);
my @cruiseKeyWord = qw(0 1);
sub isMissing { return(not (defined($_[0]) and $_[0] !~ m/^\s*$/)) }
sub askFor # prompt user and return entered value; expand valid abbreviations
my($field, $val, $expected) = @_;
die("? Missing required \$field param\n_") if (isMissing($field));
die("? missing keywords list\n_") if (scalar(@{$expected}) < 1);
if (not defined($val))
printf("%40s", "$field? (" . join(' ', @{$expected}) . "): ");
$val = <STDIN>;
my %kwAbbrev = abbrev(@{$expected});
my $keyWord = $kwAbbrev{$val};
$keyWord = $val if (not defined($keyWord));
sub echoParams # echo entered data
foreach my $param (@_) { $param = 'NUL' if (not defined($param)) }
my($trim, $seats, $wheels, $trans, $cruise) = @_;
print <<ECHO
Given: Trim: $trim
Interior: $seats
Wheels: $wheels
Transmission: $trans
Cruise Control: $cruise
# Main Line: get values from command line and/or prompt.
if (scalar(@ARGV) < 1)
foreach my $arg (@ARGV) { $arg = lc($arg) };
my $trim = askFor('Trim', shift(@ARGV), \@trimKeyWord);
print("\nEnter desired options for the ", uc($trim), " trim\n\n")
if (scalar(@ARGV) == 0);
my $seats = askFor('Interior', shift(@ARGV), \@interiorKeyWord);
my $wheels = askFor('Wheels', shift(@ARGV), \@wheelsKeyWord);
my $trans = askFor('Transmission', shift(@ARGV), \@trannieKeyWord);
my $cruise = askFor('Cruise Control', shift(@ARGV), \@cruiseKeyWord);
warn("? ignoring: '", join("', '", @ARGV), "'") if (scalar(@ARGV) > 0);
echoParams($trim, $seats, $wheels, $trans, $cruise);
my $bundleCode = bundleLookup($trim, $seats, $wheels, $trans, $cruise);
print("Selected Bundle: $bundleCode\n\n");
# EOF:
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment