Version 3/081027 of Dynamic Objects (for Glulx only) by Jesse McGrew begins here.

"Provides the ability to create new objects during game play."

Include Dynamic Tables by Jesse McGrew.

Chapter 1 - New stuff

Section 1 - Cloning objects

To decide which object is a new object cloned from (prev - an object), preserving relations: (- DO_CloneObject({prev}, {phrase options}); -).

Include (-
Constant OBJECT_STRUCT_SIZE = NUM_ATTR_BYTES + 25;

[ DO_CloneObject src opts  rv props i;
	! need to have something to copy from
	if ((src == 0) || (src->0 ~= $70)) rfalse;

	! copy property table (this also allocates the fixed-size object structure at the beginning)
	rv = DO_CloneProperties(src);
	if (~~rv) rfalse;
	props = rv + OBJECT_STRUCT_SIZE;

	! initialize object
	rv->0 = $70;						! type ID
	for ( i=1: i<=NUM_ATTR_BYTES: i++ ) rv->i = src->i;	! attributes
	i = (1 + NUM_ATTR_BYTES) / 4;
	rv-->i = 0;						! next object link
	rv-->(i+1) = src-->(i+1);					! hardware name
	rv-->(i+2) = props;					! property table
	rv-->(i+3) = 0;						! parent
	rv-->(i+4) = 0;						! sibling
	rv-->(i+5) = 0;						! child

	! insert object into Inform's linked lists
	DO_LinkObject(src, rv);

	! update relation structures and maintain invariants for symmetric relations
	DO_FixRelations(src, rv, opts);

	! update I7 structures that depend on the number of objects
	(+ dynamic objects belt loosening rule +)();

	return rv;
];

[ DO_CloneProperties src  orig size i rv;
	! find source object's property table
	src = (src + 9 + NUM_ATTR_BYTES)-->0;
	orig = src;

	! measure size of table
	size = 4;
	i = src-->0;
	src = src + 4;
	while (i > 0) {
		size = size + 10 + ((src-->0 & $FFFF) * WORDSIZE);
		src = src + 10;
		i--;
	}

	! obtain memory for new table
	rv = DT_Alloc(size + OBJECT_STRUCT_SIZE);
	if (~~rv) rfalse;
	rv = rv + OBJECT_STRUCT_SIZE;

	! copy it
	DT_CopyBytes(size, orig, rv);

	! adjust property data pointers
	i = rv-->0;
	src = rv + 4;
	while (i > 0) {
		src-->1 = src-->1 - orig + rv;
		src = src + 10;
		i--;
	}

	return rv - OBJECT_STRUCT_SIZE;
];

[ DO_LinkObject src obj  i last prop nk;
	! add obj to the linked list of all objects
	last = 0;
	for (i=Class: i: i=(i + 1 + NUM_ATTR_BYTES)-->0)
		last = i;
	if (last)
		(last + 1 + NUM_ATTR_BYTES)-->0 = obj;

	! add obj to the linked lists for each kind it's a member of
	nk = obj.IK_0;
	while (nk > 0) {
		i = nk*2;
		prop = DO_FindLinkProp(obj, KindHierarchy-->i);
		if (prop) {
			last = src;
			while (last.prop) last = last.prop;
			last.prop = obj;
			obj.prop = 0;
		}
		nk = KindHierarchy-->(i+1);
	}
];

Constant DO_PROPBUF_LEN 16;
Array do_propbuf1 buffer DO_PROPBUF_LEN;	! the kind name, e.g. "K2_thing"
Array do_propbuf2 buffer DO_PROPBUF_LEN;	! the property name, e.g. "IK2_Link"

[ DO_FindLinkProp obj kind pt i prop;
	! get kind name
	VM_PrintToBuffer(do_propbuf1, DO_PROPBUF_LEN, DO_PrintObject, kind);

	! find obj's property table
	pt = (obj + 9 + NUM_ATTR_BYTES)-->0;

	! check each property
	i = pt-->0;
	pt = pt + 4;
	while (i > 0) {
		prop = ((pt-->0) / $10000) & $FFFF;
		VM_PrintToBuffer(do_propbuf2, DO_PROPBUF_LEN, DO_PrintProperty, prop);
		if (DO_PropBufsMatch()) return prop;
		pt = pt + 10;
		i--;
	}

	rfalse;
];

[ DO_PrintObject x; print (object) x; ];
[ DO_PrintProperty x; print (property) x; ];

[ DO_PropBufsMatch  len p1 p2 c1 c2;
	len = do_propbuf1-->0;
	if (do_propbuf2-->0 <= len) len = do_propbuf2-->0 - 1;
	p1 = do_propbuf1 + WORDSIZE;
	p2 = do_propbuf2 + WORDSIZE + 1;
	while (len > 0) {
		c1 = p1->0; c2 = p2->0;
		if (c1 ~= c2) rfalse;
		if (c1 == '_') rtrue;
		len--; p1++; p2++;
	}
	rfalse;
];

[ DO_FixRelations src obj preserve  i storage;
	for (i=0: relation_metadata-->i ~= NULL: i=i+3) {
		storage = relation_metadata-->i;
		switch (relation_metadata-->(i+1)) {
			Relation_OtoO, Relation_OtoV, Relation_VtoO: if (~~preserve) DO_ClearOtoX(obj, storage);
			Relation_VtoV: relation_metadata-->i = DO_AddVtoV(obj, storage, preserve, src, 0);
			Relation_Sym_OtoO: DO_ClearOtoX(obj, storage);
			Relation_Sym_VtoV: relation_metadata-->i = DO_AddVtoV(obj, storage, preserve, src, 1);
			Relation_Equiv: if (~~preserve) DO_ClearEquiv(obj, storage);
		}
	}
];

[ DO_ClearOtoX obj prop;
	if (obj provides prop) obj.prop = nothing;
];

[ DO_ClearEquiv obj prop  last i;
	if (obj provides prop) {
		last = 0;
		objectloop (i provides prop)
			if (i.prop > last) last = i.prop;
		obj.prop = last + 1;
	}
];

Constant VTOVS_HDR_WORDS = 8;

[ DO_AddVtoV obj bitmap preserve src sym  lp rp nbmp i m l r n oli ori;
	lp = bitmap-->VTOVS_LEFT_INDEX_PROP;
	rp = bitmap-->VTOVS_RIGHT_INDEX_PROP;
	if (obj provides lp) {
		if (obj provides rp) m = 3;		! both
		else m = 1;			! left only
	} else {
		if (obj provides rp) m = 2;		! right only
		else return bitmap;
	}

	! calculate new domain size
	l = bitmap-->VTOVS_LEFT_DOMAIN_SIZE;
	if (m == 1 or 3) { oli = obj.lp; obj.lp = l; l++; }
	r = bitmap-->VTOVS_RIGHT_DOMAIN_SIZE;
	if (m == 2 or 3) { ori = obj.rp; obj.rp = r; r++; }
	n = l * r;

	! allocate memory for new bitmap
	! 1 word for static bitmap pointer + 8 word v2v header + 1 word per 16 entries in the bitmap
	nbmp = DT_Alloc((1+VTOVS_HDR_WORDS)*WORDSIZE + (n+15)/16);
	if (~~nbmp) { print "*** No memory to resize V2V relation ***"; rfalse; }

	! point from the dynamic bitmap to the static bitmap
	if (bitmap >= Blk_Heap) nbmp-->0 = bitmap-->(-1); else nbmp-->0 = bitmap;

	! point from the static bitmap to the dynamic bitmap
	(nbmp-->0)-->0 = -1;
	(nbmp-->0)-->1 = nbmp + WORDSIZE;

	! fill in V2V header
	nbmp = nbmp + WORDSIZE;
	nbmp-->VTOVS_LEFT_INDEX_PROP = lp;
	nbmp-->VTOVS_RIGHT_INDEX_PROP = rp;
	nbmp-->VTOVS_LEFT_DOMAIN_SIZE = l;
	nbmp-->VTOVS_RIGHT_DOMAIN_SIZE = r;
	nbmp-->VTOVS_LEFT_PRINTING_ROUTINE = bitmap-->VTOVS_LEFT_PRINTING_ROUTINE;
	nbmp-->VTOVS_RIGHT_PRINTING_ROUTINE = bitmap-->VTOVS_RIGHT_PRINTING_ROUTINE;
	nbmp-->VTOVS_CACHE_BROKEN = 1;
	nbmp-->VTOVS_CACHE = 0;

	! expand the bits
	l = bitmap-->VTOVS_LEFT_DOMAIN_SIZE;
	r = bitmap-->VTOVS_RIGHT_DOMAIN_SIZE;
	if (m == 2 or 3) {
		! need to insert bits for a new column
		DO_InsertBits(bitmap + VTOVS_HDR_WORDS*WORDSIZE, l * r, r, nbmp + VTOVS_HDR_WORDS*WORDSIZE);
	} else {
		! just copy
		for (i=(l*r + 15)/16: i>0: --i)
			nbmp-->(VTOVS_HDR_WORDS+i) = bitmap-->(VTOVS_HDR_WORDS+i);
	}

	! preserve relations if needed
	if (preserve) {
		if (m == 1 or 3)
			objectloop (i provides rp)
				if (Relation_TestVtoV(src, bitmap, i, sym))
					Relation_NowVtoV(obj, nbmp, i, sym);

		if ((~~sym) && m == 2 or 3)
			objectloop (i provides lp)
				if (Relation_TestVtoV(i, bitmap, src, sym))
					Relation_NowVtoV(i, nbmp, obj, sym);
	}

	! deallocate old bitmap if necessary
	if (bitmap >= Blk_Heap) DT_Free(bitmap - WORDSIZE);

	return nbmp;
];

! expands 'nbits' bits from src to dest, inserting a zero bit every
! 'interval' bits and using only the lower 16 bits of each word.
! the number of words used for dest is (nbits+(nbits/interval)+15)/16.
[ DO_InsertBits src nbits interval dest  sw sb dw db i si f;
	sw = 0; sb = 1; dw = 0; db = 1;
	nbits = nbits + (nbits / interval);
	f = 0; si = 0;
	for (i=0: i<nbits: i++) {
		if (db == 1) dest-->dw = 0;
		if (f) {
			f = 0;
		} else {
			if (src-->sw & sb) dest-->dw = dest-->dw | db;
			sb = sb * 2;
			if (sb == $10000) { sw++; sb = 1; }
			si++;
			if (si == interval) { f = 1; si = 0; }
		}
		db = db * 2;
		if (db == $10000) { dw++; db = 1; }
	}
];
-).

[We have to patch the template routines that handle various-to-various relations (Relation_TestVtoV, etc.), since I7's generated code calls them with hardcoded addresses instead of looking up our changed address in the relation_metadata array. We set the first word of the original V2V structure to -1, and the second word to the address of the latest ]

Include (-
Constant VTOVS_LEFT_INDEX_PROP = 0;
Constant VTOVS_RIGHT_INDEX_PROP = 1;
Constant VTOVS_LEFT_DOMAIN_SIZE = 2;
Constant VTOVS_RIGHT_DOMAIN_SIZE = 3;
Constant VTOVS_LEFT_PRINTING_ROUTINE = 4;
Constant VTOVS_RIGHT_PRINTING_ROUTINE = 5;
Constant VTOVS_CACHE_BROKEN = 6;
Constant VTOVS_CACHE = 7;

[ Relation_NowVtoV obj1 vtov_structure obj2 sym pr pr2 i1 i2;
	if (vtov_structure-->0 == -1) vtov_structure = vtov_structure-->1;	! JM
	if (sym && (obj2 ~= obj1)) { Relation_NowVtoV(obj2, vtov_structure, obj1, false); }
	pr = vtov_structure-->VTOVS_LEFT_INDEX_PROP;
	pr2 = vtov_structure-->VTOVS_RIGHT_INDEX_PROP;
	vtov_structure-->VTOVS_CACHE_BROKEN = true; ! Mark any cache as broken
	if (pr) {
		if ((obj1 ofclass Object) && (obj1 provides pr)) i1 = obj1.pr;
		else return RunTimeProblem(RTP_IMPREL, obj1, vtov_structure);
	} else i1 = obj1-1;
	if (pr2) {
		if ((obj2 ofclass Object) && (obj2 provides pr2)) i2 = obj2.pr2;
		else return RunTimeProblem(RTP_IMPREL, obj2, vtov_structure);
	} else i2 = obj2-1;
	pr = i1*(vtov_structure-->VTOVS_RIGHT_DOMAIN_SIZE) + i2;
	i1 = IncreasingPowersOfTwo_TB-->(pr%16);
	pr = pr/16 + 8;
	vtov_structure-->pr = (vtov_structure-->pr) | i1;
];

[ Relation_NowNVtoV obj1 vtov_structure obj2 sym pr pr2 i1 i2;
	if (vtov_structure-->0 == -1) vtov_structure = vtov_structure-->1;	! JM
	if (sym && (obj2 ~= obj1)) { Relation_NowNVtoV(obj2, vtov_structure, obj1, false); }
	pr = vtov_structure-->VTOVS_LEFT_INDEX_PROP;
	pr2 = vtov_structure-->VTOVS_RIGHT_INDEX_PROP;
	vtov_structure-->VTOVS_CACHE_BROKEN = true; ! Mark any cache as broken
	if (pr) {
		if ((obj1 ofclass Object) && (obj1 provides pr)) i1 = obj1.pr;
		else return RunTimeProblem(RTP_IMPREL, obj1, vtov_structure);
	} else i1 = obj1-1;
	if (pr2) {
		if ((obj2 ofclass Object) && (obj2 provides pr2)) i2 = obj2.pr2;
		else return RunTimeProblem(RTP_IMPREL, obj2, vtov_structure);
	} else i2 = obj2-1;
	pr = i1*(vtov_structure-->VTOVS_RIGHT_DOMAIN_SIZE) + i2;
	i1 = IncreasingPowersOfTwo_TB-->(pr%16);
	pr = pr/16 + 8;
	if ((vtov_structure-->pr) & i1) vtov_structure-->pr = vtov_structure-->pr - i1;
];

[ Relation_TestVtoV obj1 vtov_structure obj2 sym pr pr2 i1 i2;
	if (vtov_structure-->0 == -1) vtov_structure = vtov_structure-->1;	! JM
	pr = vtov_structure-->VTOVS_LEFT_INDEX_PROP;
	pr2 = vtov_structure-->VTOVS_RIGHT_INDEX_PROP;
	if (sym && (obj2 > obj1)) { sym = obj1; obj1 = obj2; obj2 = sym; }
	if (pr) {
		if ((obj1 ofclass Object) && (obj1 provides pr)) i1 = obj1.pr;
		else { RunTimeProblem(RTP_IMPREL, obj1, vtov_structure); rfalse; }
	} else i1 = obj1-1;
	if (pr2) {
		if ((obj2 ofclass Object) && (obj2 provides pr2)) i2 = obj2.pr2;
		else { RunTimeProblem(RTP_IMPREL, obj2, vtov_structure); rfalse; }
	} else i2 = obj2-1;
	pr = i1*(vtov_structure-->VTOVS_RIGHT_DOMAIN_SIZE) + i2;
	i1 = IncreasingPowersOfTwo_TB-->(pr%16);
	pr = pr/16 + 8;
	if ((vtov_structure-->pr) & i1) rtrue; rfalse;
];
-) instead of "Various To Various Relations" in "Relations.i6t".

This is the dynamic objects belt loosening rule:
	let NT be the number of things;
	ensure at least NT rows in the Table of Locale Priorities.

To ensure at least (N - number) rows in (T - table-name):
	if the number of rows in T is less than N, change T to have N + 4 rows.

Dynamic Objects ends here.

---- DOCUMENTATION ----

This extension allows new objects to be created by cloning existing objects. Once we've defined a suitable prototype object, we can refer to "a new object cloned from" it, like so:

	let the copy be a new object cloned from the prototype;

That line will create the new object and assign it to the variable called "copy". The copy will be the same kind as the prototype, and have all the same property values.

By default, the new object will not be participating in any of the relationships of the prototype object. To clone the relationships as well, use the "preserving relations" option:

	let the copy be a new object cloned from the prototype, preserving relations;

Note that even with this option, one-to-various (or various-to-one) relationships are only preserved when the cloned object is on the "various" side, and symmetric one-to-one relationships are never preserved.

Section: Caveats

Avoid cloning objects which have properties containing indexed text, stored actions, or lists.

If we plan to clone any rooms or doors, we must disable fast route-finding (which is enabled by default on Glulx):

	Use slow route-finding.

Section: Change Log

Version 2 uses Dynamic Tables (by the same author) to avoid replacing the standard locale description rules, and allows cloned objects to participate in all relations.

Version 3 works with Inform 7 version 5U92.

Example: * The Cubbins Effect - Creating a new hat every time the player removes the one he's wearing.

	*: "The Cubbins Effect" by Geodor Theisel
	
	Include Dynamic Objects by Jesse McGrew.
	
	King Derwin's Court is a room. "You have been summoned here for the crime of failing to remove your hat in the king's presence."
	
	A hat is a kind of thing.
	
	A hat style is a kind of value. The hat styles are red, blue, green, yellow, white, black, brown, zebra-striped, tall, pointy, short, gray, pink, fuzzy, rainbow-colored, and feathered.
	
	A hat has a hat style. Before printing the name of a hat, say "[hat style] ". Understand the hat style property as describing a hat.
	
	The player wears a hat which is red.
	
	Instead of taking off a hat which is worn by the player:
		now the noun is in the location;
		if 500 hats are in the location begin;
			say "You remove [the noun] and drop it. It seems that was the last one!";
			end the game in victory;
		otherwise;
			let the new hat be a new object cloned from the noun;
			now the player is wearing the new hat;
			while the hat style of the new hat is the hat style of the noun, change the hat style of the new hat to a random hat style;
			say "You remove [the noun] and drop it, only to find another hat upon your head -- a [hat style of the new hat] one.";
		end if.

	Rule for printing a number of hats (called the particular headwear):
		say "[listing group size in words] [hat style of the particular headwear] hats".
	
	Test me with "remove hat / remove hat / remove hat / i / look".