-- GFigToJaM.mesa, Cedar version
-- Last changed by M. Stone, 9-Sep-81 18:14:37

DIRECTORY
	PairList USING [Relation,NotFound,CreateRelation,AddPair,
		Right,ForAllPairs,DestroyRelation, EqualProc],
	Real USING [RoundI],
	Rope USING [Ref,Concat,Match],
	IOStream,
	Convert USING [ValueToRope],
	GriffinFig,
	Vector USING[Vec],
	Cubic USING[Bezier];

GFigToJaM: PROGRAM
	IMPORTS PairList, Rope, Convert, IOStream, Real
	EXPORTS GriffinFig =
{OPEN GriffinFig, PairList, Vector;

NoFileOpen: PUBLIC SIGNAL = CODE;
FileNotClosed: PUBLIC SIGNAL[name: Rope.Ref] = CODE;
NotAValidColorID: PUBLIC SIGNAL = CODE;
NotAValidFontID: PUBLIC SIGNAL = CODE;
NotAValidStyleID: PUBLIC SIGNAL[type: StyleType] = CODE;
NotAValidObjectID: PUBLIC SIGNAL = CODE;
NotAValidPathID: PUBLIC SIGNAL = CODE;
NoCurrentPath: PUBLIC SIGNAL = CODE;
PathAlreadyStarted: PUBLIC SIGNAL = CODE;
NotAValidClusterID: PUBLIC SIGNAL = CODE;
NoCurrentCluster: PUBLIC SIGNAL = CODE;
ClusterAlreadyStarted: PUBLIC SIGNAL = CODE;

Stream: IOStream.Handle _ NIL;
FileName: Rope.Ref _ NIL;

-- Conversion constants:  Press -> Alto
PressToAltoScaleFactor: REAL = 0.03125;
	
--files

NewFile: PUBLIC PROC[name: Rope.Ref] = {
	IF Stream#NIL THEN SIGNAL FileNotClosed[FileName];
	InitDataStructures[];
	FileName _ NIL;
	FileName _ Rope.Concat[FileName,name];
	IF ~Rope.Match["*.jam", FileName, FALSE] THEN FileName _ Rope.Concat[FileName,".jam"];
	Stream _ IOStream.CreateFileStream[FileName,overwrite];
	WName[name]; WS[" /begin"];
	WS["\n% The following definition includes a circumlocution for LineWidth"];
	WS["\n% to always have the value 0. Remove the .pop when CGStrokeImpl"];
	WS["\n% accepts non-unit line widths."];
	WS["\n(linewidth) (.pop 0 (LineWidth) .exch .store).cvx .def"];
	};

CloseFile: PUBLIC PROC = {
	wn: PROC[leftPart, rightPart: REF ANY] = {WS[NARROW[rightPart]]; WS[" "]};
	IF Stream=NIL THEN SIGNAL NoFileOpen;
--ForAllPairs gives inverse chronological order.  We need the opposite
	ReverseObjects[];
	WS["\n(refresh) ("];
	ForAllPairs[ObjectRelation,wn];
	WS[") .cvx .def\n"];
	IOStream.Close[Stream,TRUE];
	Stream _ NIL;
	};

--to call from debugger
DebugCloseFile: PUBLIC PROC = {
	IOStream.Close[Stream,TRUE];
	Stream _ NIL;
	};

Comment: PUBLIC PROC[string: Rope.Ref] = {
	WName[string];
	WS[" .pop\n"];
	};

--style information
Color: PUBLIC PROC[h,s,b: [0..255], texture: CARDINAL] RETURNS [ColorID] = {
--relation will have a pointer to this string
	id: CARDINAL _ TestAndAdd[color];
	WN[h]; WN[s]; WN[b];
	WS[" .sethsb"];
	WUN[texture];	 
	WS[" .setcolor) .cvx .def"];
	RETURN[id];
	};

Font: PUBLIC PROC[name: Rope.Ref, charOrientation: REAL] RETURNS [FontID] = {
	id: CARDINAL _ TestAndAdd[font];
	WName[name];
	WS[" .setfont"];
	WR[charOrientation];
	WS[" .charorientation) .cvx .def"];
	RETURN[id];
	};

LineStyle: PUBLIC PROC[colorID: ColorID, width: REAL] RETURNS [LineStyleID] = {
	id: CARDINAL _ TestAndAdd[linestyle];
	colorName: Rope.Ref _ CheckID[colorID,color];
	WS[colorName];
	WR[width];
	WS[" linewidth) .cvx .def"];
	RETURN[id];
	};

FillStyle: PUBLIC PROC[colorID: ColorID] RETURNS [FillStyleID] = {
	id: CARDINAL _ TestAndAdd[fillstyle];
	colorName: Rope.Ref _ CheckID[colorID,color];
	WS[colorName];
	WS[") .cvx .def"];
	RETURN[id];
	};

TextStyle: PUBLIC PROC[colorID: ColorID, fontID: FontID] RETURNS [TextStyleID] = {
	id: CARDINAL _ TestAndAdd[textstyle];
	colorName: Rope.Ref _ CheckID[colorID,color];
	fontName: Rope.Ref _ CheckID[fontID,font];
	WS[colorName];
	WS[" "];
	WS[fontName];
	WS[") .cvx .def"];
	RETURN[id];
	};


--paths
newBoundary: BOOLEAN _ FALSE;
CurrentPathID: CARDINAL _0;
StartPath: PUBLIC PROC = {
	IF CurrentPathID#0 THEN SIGNAL PathAlreadyStarted;
	CurrentPathID _ TestAndAdd[path];
	newBoundary _ TRUE;
	};

EnterPoint: PUBLIC PROC[p: Vec] = {
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	IF CurrentPathID=0 THEN SIGNAL NoCurrentPath;
	WP[p];
	};

EnterCubic: PUBLIC PROC[c: Cubic.Bezier] = {
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	IF CurrentPathID=0 THEN SIGNAL NoCurrentPath;
	WC[c];
	};

NewBoundary: PUBLIC PROC = {
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	IF CurrentPathID=0 THEN SIGNAL NoCurrentPath;
	newBoundary _ TRUE;
	};

--To use the path in the file, need .linepath, .areapath or .closedlinepath
--following in the stream
EndPath: PUBLIC PROC RETURNS [PathID] = {
	return: PathID;
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	IF CurrentPathID=0 THEN SIGNAL NoCurrentPath;
	WS[") .cvx .def"];
	return _ CurrentPathID;
	CurrentPathID _ 0;
	RETURN[return];
	};


--objects

LineObject: PUBLIC PROC[lineStyleID: LineStyleID, pathID: PathID] RETURNS [ObjectID] = {
	id: CARDINAL _ TestAndAdd[object];
	styleName: Rope.Ref _ CheckID[lineStyleID,linestyle];
	pathName: Rope.Ref _ CheckID[pathID,path];
	WS[styleName]; WS[" "]; WS[pathName]; WS[ " LineWidth .drawpath) .cvx .def"];
	RETURN[id];
	};

AreaObject: PUBLIC PROC[fillStyleID: FillStyleID, lineStyleID: LineStyleID, pathID: PathID] RETURNS [ObjectID] = {
	id: CARDINAL _ TestAndAdd[object];
	pathName: Rope.Ref _ CheckID[pathID,path];
	styleName: Rope.Ref;
	IF fillStyleID#NullStyle THEN {
		styleName _ CheckID[fillStyleID,fillstyle];
		WS[styleName]; WS[" "]; WS[pathName]; WS[" "]; WS[".drawarea "];
		};
	IF lineStyleID#NullStyle THEN {
		styleName _ CheckID[lineStyleID,linestyle];
		WS[styleName]; WS[" "]; WS[pathName]; WS[" LineWidth .drawpath"];
		};
	WS[ ") .cvx .def"];
	RETURN[id];
	};

--this is complicated because of the left, right, center anchor
--on griffin text.  
TextObject: PUBLIC PROC[styleID: TextStyleID, text: Rope.Ref, anchorType: AnchorType, anchor: Vec, rot: REAL] RETURNS [ObjectID] = {
	id: CARDINAL _ TestAndAdd[object];
	styleName: Rope.Ref _ CheckID[styleID,textstyle];
	WS[".pushdc "]; WS[styleName];
	WP[anchor]; WS[" .moveto"];
	WR[rot]; WS[" .rotate "]; WName[text]; WS[" altotoobject"];
--these procedures should use the .textbox function to recompute
--the origin for the .drawtext
	SELECT anchorType FROM
		left => WS[" left"];
		right => WS[" right"];
		center => WS[" center"];
		ENDCASE => ERROR;
	WS[" .drawtext .popdc) .cvx .def"];
	RETURN[id];
	};


--clusters

CurrentClusterID: CARDINAL _0;
StartCluster: PUBLIC PROC = {
	IF CurrentClusterID#0 THEN SIGNAL ClusterAlreadyStarted;
	CurrentClusterID _ TestAndAdd[cluster];
	};

EnterObject: PUBLIC PROC[objectID: ObjectID] = {
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	WS[CheckID[objectID, object]];
	WS[" "];
	};

EnterCluster: PUBLIC PROC[clusterID: ClusterID] = {
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	WS[CheckID[clusterID, cluster]];
	};

--finishes current cluster
Cluster: PUBLIC PROC RETURNS [ClusterID] = {
	return: ClusterID;
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	IF CurrentClusterID=0 THEN SIGNAL NoCurrentCluster;
	WS[") .cvx .def"];
	return _ CurrentClusterID;
	CurrentClusterID _ 0;
	RETURN[return];
	};

--private procedures

InitDataStructures: PROC = {
	DestroyRelation[ColorRelation];
	DestroyRelation[FontRelation];
	DestroyRelation[LineStyleRelation];
	DestroyRelation[FillStyleRelation];
	DestroyRelation[TextStyleRelation];
	DestroyRelation[PathRelation];
	DestroyRelation[ObjectRelation];
	DestroyRelation[ClusterRelation];
	ColorRelation _ FontRelation _ LineStyleRelation _ FillStyleRelation _ TextStyleRelation _ PathRelation _ ObjectRelation _ ClusterRelation _ NIL;
	ColorNum _ FontNum _ LStyleNum _ FStyleNum _ TStyleNum _  PathNum _ ObjectNum _ ClusterNum _ 1;
	FileName _ NIL;
	};

--relation handling procs
RelType: TYPE =
	{color,font,linestyle,fillstyle,textstyle,path,object,cluster};
ColorRelation: Relation _ NIL;
FontRelation: Relation _ NIL;
LineStyleRelation: Relation _ NIL;
FillStyleRelation: Relation _ NIL;
TextStyleRelation: Relation _ NIL;
PathRelation: Relation _ NIL;
ObjectRelation: Relation _ NIL;
ClusterRelation: Relation _ NIL;

--so ForAllPairs in generating refresh command gives chronological order
ReverseObjects: PROC= {
	new: Relation _ CreateRelation[];
	add: PROC [leftPart, rightPart: REF ANY] = {
		AddPair[new,leftPart,rightPart]};
	IF ObjectRelation=NIL THEN RETURN;
	ForAllPairs[ObjectRelation,add];
	ObjectRelation _ new;
	};

TestAndAdd: PROC [type: RelType] RETURNS [id: CARDINAL] = {
--relation will have a pointer to this string
	name: Rope.Ref;
	refID: REF CARDINAL;
	relation: Relation _ NIL;
	IF Stream=NIL THEN SIGNAL NoFileOpen;
	SELECT type FROM
	  color => relation _ ColorRelation _ EnsureNotNil[ColorRelation];
	  font => relation _ FontRelation _ EnsureNotNil[FontRelation];
	  linestyle => relation _ LineStyleRelation _ EnsureNotNil[LineStyleRelation];
	  fillstyle => relation _ FillStyleRelation _ EnsureNotNil[FillStyleRelation];
	  textstyle => relation _ TextStyleRelation _ EnsureNotNil[TextStyleRelation];
	  path => relation _ PathRelation _ EnsureNotNil[PathRelation];
	  object => relation _ ObjectRelation _ EnsureNotNil[ObjectRelation];
	  cluster => relation _ ClusterRelation _ EnsureNotNil[ClusterRelation];
	  ENDCASE => ERROR;
	[name,id] _ NextID[type];
	refID _ NEW[CARDINAL _ id];
	AddPair[relation,refID,name];
	WS["\n"]; WName[name]; WS[" ("];
	};

EnsureNotNil: PROC [r: Relation] RETURNS [Relation] = {
  RETURN [IF r = NIL THEN CreateRelation[] ELSE r];
  };
  
CheckID: PROC [id: CARDINAL, type: RelType] RETURNS [Rope.Ref] = {
	name: Rope.Ref;
	refID: REF CARDINAL _ NEW[CARDINAL _ id];
	equalCardinal: PairList.EqualProc = {
		IF ISTYPE[right, REF CARDINAL]
			THEN IF NARROW[right,REF CARDINAL]^ = NARROW[left,REF CARDINAL]^
				THEN RETURN[TRUE]
		ELSE RETURN[FALSE];
		};
	SELECT type FROM
		color =>
			{ENABLE NotFound => {SIGNAL NotAValidColorID; CONTINUE};
			name _ NARROW[Right[ColorRelation,equalCardinal,refID]]};
		font =>
			{ENABLE NotFound => {SIGNAL NotAValidFontID; CONTINUE};
			name _ NARROW[Right[FontRelation,equalCardinal,refID]]};
		linestyle =>
			{ENABLE NotFound => {SIGNAL NotAValidStyleID[line]; CONTINUE};
			name _ NARROW[Right[LineStyleRelation,equalCardinal,refID]]};
		fillstyle =>
			{ENABLE NotFound => {SIGNAL NotAValidStyleID[fill]; CONTINUE};
			name _ NARROW[Right[FillStyleRelation,equalCardinal,refID]]};
		textstyle =>
			{ENABLE NotFound => {SIGNAL NotAValidStyleID[text]; CONTINUE};
			name _ NARROW[Right[TextStyleRelation,equalCardinal,refID]]};
		path =>
			{ENABLE NotFound => {SIGNAL NotAValidPathID; CONTINUE};
			name _ NARROW[Right[PathRelation,equalCardinal,refID]]};
		object =>
			{ENABLE NotFound => {SIGNAL NotAValidObjectID; CONTINUE};
			name _ NARROW[Right[ObjectRelation,equalCardinal,refID]]};
		cluster =>
			{ENABLE NotFound => {SIGNAL NotAValidClusterID; CONTINUE};
			name _ NARROW[Right[ClusterRelation,equalCardinal,refID]]};
		ENDCASE => ERROR;
	RETURN[name];
	};

--generate id's.  Keep it simple for now

ColorName: Rope.Ref _ "c";
FontName: Rope.Ref _ "f";
LineStyleName: Rope.Ref _ "ls";
FillStyleName: Rope.Ref _ "fs";
TextStyleName: Rope.Ref _ "ts";
PathName: Rope.Ref _ "p";
ObjectName: Rope.Ref _ "obj";
ClusterName: Rope.Ref _ "clu";
ColorNum,FontNum,LStyleNum,FStyleNum,TStyleNum: CARDINAL _ 1;
PathNum,ObjectNum,ClusterNum: CARDINAL _ 1;
NextID: PROC [type: RelType] RETURNS [name: Rope.Ref, id: CARDINAL] = {
	typeName: Rope.Ref;
	SELECT type FROM
		color => {id _ ColorNum; ColorNum _ ColorNum+1};
		font => {id _ FontNum; FontNum _ FontNum+1};
		linestyle => {id _ LStyleNum; LStyleNum _ LStyleNum+1};
		fillstyle => {id _ FStyleNum; FStyleNum _ FStyleNum+1};
		textstyle => {id _ TStyleNum; TStyleNum _ TStyleNum+1};
		path => {id _ PathNum; PathNum _ PathNum+1};
		object => {id _ ObjectNum; ObjectNum _ ObjectNum+1};
		cluster => {id _ ClusterNum; ClusterNum _ ClusterNum+1};
		ENDCASE => ERROR;
	typeName _ (SELECT type FROM
		color => ColorName,
		font => FontName,
		linestyle => LineStyleName,
		fillstyle => FillStyleName,
		textstyle => TextStyleName,
		path => PathName,
		object => ObjectName,
		cluster => ClusterName,
		ENDCASE => ERROR);
	name _ typeName;
	name _ Rope.Concat[name,Convert.ValueToRope[[signed[id,10]]]];
	};

--file writing procs

WS: PROC [s: Rope.Ref] = {
	IOStream.PutRope[Stream,s];
	};

WName: PROC [s: Rope.Ref] = {OPEN IOStream;
	Put[Stream,char['(], rope[s], char[')]];
	};

--write it unsigned, base 8
WUN: PROC [n: CARDINAL] = {OPEN IOStream;
	PutF[Stream," %bB",card[n]];
	};

--write it signed, base 10
WN: PROC [n: INTEGER] = {OPEN IOStream;
	Put[Stream,char[SP],int[n] ];
	};

WR: PROC [r: REAL] = {OPEN IOStream;
	Put[Stream,char[SP],int[Real.RoundI[r*PressToAltoScaleFactor]] ];
	};

WP: PROC [p: Vec] = {
	WR[p.x];
	WR[p.y];
	IF newBoundary THEN WS[" .moveto\n"] 
	ELSE WS[" .lineto\n"];
	newBoundary _ FALSE;
	};


WriteBB: PROC [ll,ur: Vec] = {
	WR[ll.x];
	WR[ll.y];
	WR[ur.x];
	WR[ur.y];
	WS[" bb"];
	};

WC: PROC [c: Cubic.Bezier] = {
	IF newBoundary THEN WP[c.b0];
	WR[c.b1.x];
	WR[c.b1.y];
	WR[c.b2.x];
	WR[c.b2.y];
	WR[c.b3.x];
	WR[c.b3.y];
	WS[ " .curveto\n"];
	};

}.