package PPD;

use strict;
use warnings;

use Exporter 'import';
our @EXPORT = qw(define_group define_ui_group switch_group declare get set maybe_set option int_option constrain gen_values fonts generate);

### PPD data model ###

### Keywords ###
# Key => {
#	Key => key,
#	Name => name,		# descriptive name (default: same as Key)
#	Mandatory => bool,
#	Group => name,
#
#	# For main keywords:
#	Type => type,		# q=quoted, i=invocation, s=string (unquoted), b=boolean
#	Value => string,
#	Values => list,		# (if there are multiple values)
#
#	# For option keywords:
#	Type => 'o',
#	Choice => choice,	# for UI options: PickOne / PickMany / Boolean
#	JCL => 1,		# if this is a JCL option
#	Section => sec,		# OrderDependency section: ExitServer / Prolog / DocumentSetup /
#				# PageSetup / JCLSetup (default if JCL=1) / AnySetup (default if JCL=0)
#	Priority => pri,	# OrderDependency priority, default = 100
#	Values => [		# possible values (mandatory)
#		{ Key => key,		# key (mandatory)
#		  Name => name,		# descriptive name (default: same as Key)
#		  PS => string,		# PS code invocation to emit
#		  String => string,	# Unquoted string to emit instead of PS code
#		  Default => 1,		# if this is the default value
#		},
#	],
#	Default => key,		# default value; if not specified, use the value marked with Default=1,
#				# or the first value if none is marked
#	Custom => {		# further values with custom parameters (mostly a CUPS extension)
#		PS => string,		# PS code invocation to emit (with parameters on the stack)
#					# For JCL options, a JCL command is given with "\1" etc.
#					# as placeholders for the actual values.
#		Params => [		# list of parameters (mandatory)
#			{ Key => key,		# key (mandatory)
#			  Name => name,		# descriptive name (default: same as Key)
#			  Unit => unit,		# unit: int / points / real / string / ...
#			  Min => min,
#			  Max => max,
#			},
#		]
#	},
# }
my %keywords = ();

### Groups ###
# Key => {
#	Key => key,
#	UI => 1,		# if a UI group
#	Name => name,		# descriptive name
#	Keywords => [...]	# list of keywords inside the group
# }
my %groups = ();
my @head_groups = ();
my @ui_groups = ();
my @nonui_groups = ();
my $current_group_key;

### Constraints ###
# {
# 	Name => name,
# 	Pairs => [{
#		K1 => key,
#		V1 => value,
#		K2 => key,
#		V2 => value,
#	}],
# ]
my @constraints = ();

sub define_group($) {
	my ($g) = @_;
	my $key = $g->{Key};
	!defined $groups{$key} or die "Group $key already exists\n";
	$groups{$key} = $g;
	if ($g->{UI}) { push @ui_groups, $key; }
	elsif ($g->{Head}) { push @head_groups, $key; }
	else { push @nonui_groups, $key; }
	$current_group_key = $key;
}

sub define_head_group($) {
	my ($g) = @_;
	$g->{Head} = 1;
	define_group($g);
}

sub define_ui_group($) {
	my ($g) = @_;
	$g->{UI} = 1;
	define_group($g);
}

sub switch_group($) {
	my ($key) = @_;
	$groups{$key} or die "Group $key does not exist\n";
	my $prev = $current_group_key;
	$current_group_key = $key;
	return $prev;
}

# declare("group", ["keyword", "type[!]", "value"], ...)
sub declare($@) {
	my $gn = shift @_;
	my $g = $groups{$gn} or die "Group $gn does not exist\n";
	for my $ktn (@_) {
		my ($key, $type, $value) = @$ktn;
		my $mand = 0;
		if ($type =~ s/!$//) { $mand = 1; }
		!$keywords{$key} or die "Keyword $key already declared\n";
		$keywords{$key} = {
			Key => $key,
			Name => $key,
			Group => $gn,
			Type => $type,
			Value => $value,
		};
		$keywords{$key}{Mandatory} = 1 if $mand;
		push @{$g->{Keywords}}, $keywords{$key};
	}
}

# get("keyword")
sub get($) {
	my ($key) = @_;
	my $kw = $keywords{$key};
	if ($kw) {
		return $kw->{Value} // (defined $kw->{Values} ? $kw->{Values}[0] : undef);
	} else {
		return;
	}
}

# set("option", value) or set("option", [values]) [must be already declared]
sub set($$) {
	my ($key, $value) = @_;
	my $k = $keywords{$key} or die "Unknown keyword $key (missing declaration)\n";
	if (ref $value) {
		delete $k->{Value};
		$k->{Values} = $value;
	} else {
		$k->{Value} = $value;
		delete $k->{Values};
	}
}

# maybe_set("option", value) [must be already declared]
sub maybe_set($$) {
	my ($key, $value) = @_;
	my $k = $keywords{$key} or die "Unknown keyword $key (missing declaration)\n";
	$k->{Value} //= $value;
}

# option({ Group => group, Key => key, Name => name, ... other keyword parameters })
sub option($) {
	my ($o) = @_;
	my $key = $o->{Key};
	!defined $keywords{$key} or die "Keyword $key already known\n";
	$keywords{$key} = $o;
	$o->{Group} //= $current_group_key;
	my $g = $groups{$o->{Group}};
	$o->{Type} = 'o';
	push @{$g->{Keywords}}, $o;
}

# Generator of integer options
# int_option({
#	generic option parameters
#	Int => {
#		Min => minimum,
#		Max => maximum,
#		Step => step for fixed choices,
#		FixedPS => a subroutine generating code for fixed choices,
#		CustomKey => name of the custom parameter,
#		CustomPS => code for custom choice (for JCL options, defaults to calling FixedPS with value '\1'),
#	}
# })
sub int_option($) {
	my ($o) = @_;
	my $s = $o->{Int};
	my $step = $s->{Step} // 1;
	my @vals = map { $_ * $step } int($s->{Min} / $step) .. int($s->{Max} / $step);
	$vals[0] == $s->{Min} or unshift @vals, $s->{Min};
	$vals[$#vals] == $s->{Max} or push @vals, $s->{Max};
	$o->{Choice} = 'PickOne';
	$o->{Values} = [ map +{
			Key => ($_==0 ? 0 : $_>0 ? "Plus$_" : ("Minus" . -$_)),
			Name => $_,
			PS => $s->{FixedPS}->($_),
		}, @vals ];
	$o->{Default} = 0;
	$o->{Custom} = {
		PS => $s->{CustomPS} // $s->{FixedPS}->('\1'),
		Params => [{
			Key => $s->{CustomKey},
			Unit => 'int',
			Min => $s->{Min},
			Max => $s->{Max},
		}],
	};
	option($o);
}

sub is_false($) {
	return $_[0] =~ m{^(None|False)$};
}

sub constrain($$$$) {
	my ($name, $k1, $k2, $condition) = @_;
	$name //= "$k1 vs. $k2";
	$k1 ne $k2 or die "Want to create constrait between a keyword $k1 and itself\n";
	my $kw1 = $keywords{$k1} or die "Want to create constraint for unknown keyword $k1\n";
	my $kw2 = $keywords{$k2} or die "Want to create constraint for unknown keyword $k2\n";
	$kw1->{Type} eq 'o' && $kw2->{Type} eq 'o' or die "Want to create constraint between non-option keywords $k1 and $k2\n";

	# Evaluate which combinations are permitted
	my @vals1 = map { $_->{Key} } @{$kw1->{Values}};
	my @vals2 = map { $_->{Key} } @{$kw2->{Values}};
	my %allow = ();
	for my $v1 (@vals1) {
		for my $v2 (@vals2) {
			$allow{$v1}{$v2} = $condition->($v1, $v2) ? 1 : 0;
		}
	}

	my @c = ();

	my $case1 = sub {
		# Special case 1: Forbid True & True
		for my $v1 (@vals1) {
			for my $v2 (@vals2) {
				if (is_false($v1) || is_false($v2)) {
					$allow{$v1}{$v2} or return;
				} else {
					!$allow{$v1}{$v2} or return;
				}
			}
		}
		push @c, { K1 => $k1, K2 => $k2 };
		return 1;
	};

	my $case2 = sub {
		# Special case 2: Forbid True & subset
		my %res = ();
		for my $v1 (@vals1) {
			for my $v2 (@vals2) {
				if (is_false($v1)) {
					$allow{$v1}{$v2} or return;
				} else {
					my $a = $allow{$v1}{$v2};
					$res{$v2} //= $a;
					$res{$v2} == $a or return;
				}
			}
		}
		for my $v2 (@vals2) {
			!$res{$v2} and push @c, { K1 => $k1, K2 => $k2, V2 => $v2 };
		}
		return 1;
	};

	my $case3 = sub {
		# Special case 3: Forbid subset & True
		my %res = ();
		for my $v1 (@vals1) {
			for my $v2 (@vals2) {
				if (is_false($v2)) {
					$allow{$v1}{$v2} or return;
				} else {
					my $a = $allow{$v1}{$v2};
					$res{$v1} //= $a;
					$res{$v1} == $a or return;
				}
			}
		}
		for my $v1 (@vals1) {
			!$res{$v1} and push @c, { K1 => $k1, K2 => $k2, V1 => $v1 };
		}
		return 1;
	};

	my $case4 = sub {
		# General case
		for my $v1 (@vals1) {
			for my $v2 (@vals2) {
				$allow{$v1}{$v2} or push @c, { K1 => $k1, V1 => $v1, K2 => $k2, V2 => $v2 };
			}
		}
	};

	$case1->() || $case2->() || $case3->() || $case4->() || return;
	@c or return;

	push @constraints, {
		Name => $name,
		Pairs => [
			@c,
			map(+{ K1 => $_->{K2}, K2 => $_->{K1}, V1 => $_->{V2}, V2 => $_->{V1} }, @c),
		],
	};
}

### Auxiliary functions ###

sub gen_values($@) {
	my $template = shift @_;
	my @values = ();
	while (@_) {
		my $v = shift @_;
		if (!ref $v) {
			$v = { Key => $v };
		}
		if (!defined $v->{PS}) {
			$v->{PS} = sprintf($template, $v->{Key});
		}
		push @values, $v;
	}
	return \@values;
}

sub fonts($) {
	my ($flist) = @_;
	my @values = ();
	for my $row (split /\n/, $flist) {
		my ($key, $val) = ($row =~ /^(\S+):\s+(.*)$/) or die "Font line parse error: $row\n";
		push @values, { Key => $key, String => $val };
	}

	option({
		Key => 'Font',
		Group => 'fonts',
		Values => [ @values ],
		Default => 'Courier',
	});
}

### Known main keywords ###

# Group "f": file description
define_head_group({ Key => 'f', Name => 'File version' });
declare('f',
	[ 'FormatVersion',		'q!',	'4.3' ],
	[ 'LanguageEncoding',		's!',	'ISOLatin1' ],
	[ 'LanguageVersion',		's!',	'English' ],
	[ 'FileVersion',		'q!',	undef ],
	[ 'PCFileName',			's!',	undef ],
);

# Group "p": product description
define_head_group({ Key => 'p', Name => 'Product description' });
declare('p',
	[ 'Manufacturer',		'q!',	undef ],
	[ 'ModelName',			'q!',	undef ],	# default: concatenate Manufacturer and Product
	[ 'NickName',			'q!',	undef ],	# default: copy ModelName
	[ 'ShortNickName',		'q!',	undef ],	# default: copy NickName
	[ 'Product',			'q!',	undef ],
	[ 'PSVersion',			'q!',	undef ],
);

# Group "d": device capabilities
define_head_group({ Key => 'd', Name => 'Device capabilities' });
declare('d',
	[ 'ColorDevice',		'b',	0 ],
	[ 'DefaultColorSpace',		's',	'Gray' ],
	[ 'FileSystem',			'b',	0 ],
	[ 'Extensions',			's',	undef ],
	[ 'FaxSupport',			's',	undef ],
	[ 'LanguageLevel',		'q',	undef ],
	[ 'Throughput',			'q',	undef ],
	[ 'TTRasterizer',		's',	undef ],
	[ '1284Modes',			's',	undef ],
	[ '1284DeviceID',		'q',	undef ],
	[ 'FreeVM',			'q',	undef ],
	# VMOption not supported yet
	[ 'VariablePaperSize',		'b',	1 ],
	[ 'Protocols',			's',	undef ],
	[ 'AccurateScreensSupport',	'b',	undef ],
);

# Group "c": CUPS options
define_head_group({ Key => 'c', Name => 'CUPS options' });
declare('c',
	[ 'cupsFilter',			's',	undef ],
);

# Group "j": JCL options
define_head_group({ Key => 'j', Name => 'JCL options' });
declare('j',
	[ 'JCLBegin',			'q',	undef ],
	[ 'JCLToPSInterpreter',		'q',	undef ],
	[ 'JCLToPDFInterpreter',	'q',	undef ],
	[ 'JCLEnd',			'q',	undef ],
);

# Group "fonts": Fonts
define_group({ Key => 'fonts', Name => 'Fonts' });

### Formatting of PPD ###

sub format_value($$) {
	my ($type, $value) = @_;
	$type //= 'q';
	if ($type eq 'q' || $type eq 'i') {
		# Quoted value / Invocation value
		if ($value =~ /["\x00-\x08\x0b-\x1f\x7f-\xff]/) { die "Invalid value: $value\n"; }
		$value = '"' . $value . '"';
		if ($value =~ /\n/) { $value .= "\n*End"; }
		return $value;
	} elsif ($type eq 's') {
		# String value
		return $value;
	} elsif ($type eq 'b') {
		# Boolean value
		return $value ? "True" : "False";
	} else {
		die "Unknown type '$type'\n";
	}
}

sub heading($) {
	my ($h) = @_;
	print "\n";
	print "*% ", "=" x length $h, "\n";
	print "*% ", $h, "\n";
	print "*% ", "=" x length $h, "\n";
	print "\n";
}

sub get_default($) {
	my ($o) = @_;
	exists $o->{Default} and return $o->{Default};	# may be undef
	for my $val (@{$o->{Values}}) {
		return $val->{Key} if $val->{Default};
	}
	return $o->{Values}->[0]->{Key};
}

sub emit_option($) {
	my ($o) = @_;
	my $key = $o->{Key};
	print "*% === $key ===\n";

	my $jcl = ($o->{JCL} // ($key =~ /^JCL/)) ? "JCL" : "";
	if (defined $o->{Choice}) {
		print "*${jcl}OpenUI *$key/", ($o->{Name} // $o->{Key}), ": ", $o->{Choice}, "\n";
	}

	if (defined($o->{Choice}) || defined($o->{Priority}) || defined($o->{Section})) {
		my $pri = $o->{Priority} // 100;
		my $sec = $o->{Section} // ($jcl ? "JCLSetup" : "AnySetup");
		print '*', ((defined $o->{Choice}) ? "" : 'NonUI'), "OrderDependency: $pri $sec *$key\n";
	}

	# Normal option
	my $def = get_default($o);
	print "*Default$key: $def\n" if defined $def;
	for my $v (@{$o->{Values}}) {
		my $ps = $v->{PS};
		print "*$key ", $v->{Key};
		print '/', $v->{Name} if defined($v->{Name}) && $v->{Name} ne $v->{Key};
		print ": ";
		if (defined $ps) {
			# $ps = "\n$ps" unless $ps =~ /^\n/s;
			# $ps = "$ps\n" unless $ps =~ /\n$/s;
			print format_value('i', $ps);
		} else {
			print format_value('s', $v->{String});
		}
		print "\n";
	}

	if (defined $o->{Choice}) { print "*${jcl}CloseUI: *$key\n"; }

	my $c = $o->{Custom};
	if ($c) {
		print "\n";
		print "*Custom$key True: ", format_value('i', $c->{PS}), "\n";
		my $i = 0;
		for my $p (@{$c->{Params}}) {
			$i++;
			print "*ParamCustom$key ", $p->{Key};
			print '/', $p->{Name} if defined($p->{Name}) && $p->{Name} ne $p->{Key};
			printf ": %d %s %d %d\n", $i, $p->{Unit}, $p->{Min}, $p->{Max};
		}
	}

	print "\n";
}

sub emit_keyword($) {
	my ($k) = @_;
	if ($k->{Type} eq 'o') {
		emit_option($k);
	} elsif ($k->{Value} || $k->{Values}) {
		my $vals = $k->{Values} // [ $k->{Value} ];
		for my $t (@$vals) {
			print "*", $k->{Key}, ": ", format_value($k->{Type}, $t), "\n";
		}
	}
}

sub emit_group($) {
	my ($g) = @_;
	my $keywords = $g->{Keywords};
	$keywords && @$keywords or return;
	heading($g->{Name});
	if ($g->{UI}) { print '*OpenGroup: ', $g->{Key}, '/', ($g->{Name} // $g->{Key}), "\n\n"; }
	for my $k (@$keywords) {
		emit_keyword($k);
	}
	if ($g->{UI}) { print '*CloseGroup: ', $g->{Key}, "\n"; }
}

sub emit_constraints() {
	for my $cc (@constraints) {
		heading($cc->{Name});
		for my $c (@{$cc->{Pairs}}) {
			my $c1 = $c->{K1};
			$c1 .= ' ' . $c->{V1} if defined $c->{V1};
			my $c2 = $c->{K2};
			$c2 .= ' ' . $c->{V2} if defined $c->{V2};
			printf "*%sUIConstraints: *%s *%s\n",
				((!$keywords{$c->{K1}}->{Choice} || !$keywords{$c->{K2}}->{Choice})) ? "Non" : "",
				$c1,
				$c2;
		}
	}
}

sub fill_defaults() {
	my $mfg = get('Manufacturer');
	my $prod = get('Product');
	if (defined($mfg) && defined($prod)) {
		maybe_set('ModelName', $mfg . ' ' . $prod);
	}

	maybe_set('NickName', get('ModelName')) if defined get('ModelName');
	maybe_set('ShortNickName', get('NickName')) if defined get('NickName');

	my $psver = get('PSVersion');
	if (defined($psver) && $psver =~ /\((\d)/) {
		maybe_set('LanguageLevel', $1);
	}
}

sub check_missing() {
	for my $key (keys %keywords) {
		my $k = $keywords{$key};
		if ($k->{Mandatory} && !defined $k->{Value} && !defined $k->{Values}) {
			die "Mandatory keyword $key not set\n";
		}
	}
}

sub generate() {
	fill_defaults();
	check_missing();

	print "*PPD-Adobe: ", format_value('q', get('FormatVersion')), "\n";
	print "*% PPD file generated by KAM PPD generator\n";

	for my $g (@head_groups, @ui_groups, @nonui_groups) {
		emit_group($groups{$g});
	}

	emit_constraints();
}

42;