[mercury-users] Circular lists

[Thomas Charles CONWAY]

Fergus Henderson, you write:
> > 
> > With all this talk of circular lists, I thought people might be
> > interested/amused by the following.
> > 
> > Beware, it is a complete hack, but IMHO quite cute.
> 
> Heaven forbid!  "Cute" is not the word that springs to mind ;-)
> 
> Actually you don't need to use the C interface.  You can do this
> sort of thing using the existing features of Mercury (>= 0.7.2),
> namely the `store' module, as shown below.
> 

I wrote the inflist module in 1 minute after writing the following
"chain" module this morning while waiting for hydra to reboot....

:- module chain.

:- interface.

:- import_module std_util.

:- type chain(T).

:- type handle(T).

:- pred chain__init(chain(T)::uo) is det.

:- pred chain__insert(T, chain(T), chain(T)).
:- mode chain__insert(in, di, uo) is det.

:- pred chain__insert(T, handle(T), chain(T), chain(T)).
:- mode chain__insert(in, out, di, uo) is det.

:- pred chain__first(maybe(handle(T)), chain(T), chain(T)).
:- mode chain__first(out, di, uo) is det.

:- pred chain__next(handle(T), handle(T), chain(T), chain(T)).
:- mode chain__next(in, out, di, uo) is det.

:- pred chain__prev(handle(T), handle(T), chain(T), chain(T)).
:- mode chain__prev(in, out, di, uo) is det.

:- pred chain__deref(handle(T), T, chain(T), chain(T)).
:- mode chain__deref(in, out, di, uo) is det.

:- pred chain__update(handle(T), T, chain(T), chain(T)).
:- mode chain__update(in, in, di, uo) is det.

:- implementation.

:- import_module require, store.

:- type chain(T)
	--->	chain(
			store(some_store_type),
			mutvar(elem(T), some_store_type)
		).

:- type cstore == store(some_store_type).

:- type handle(T) ==	mutvar(elem(T), some_store_type).

:- type elem(T)
	--->	empty
	;	elem(
			handle(T), % prev
			handle(T), % next
			T
		).

chain__init(mkchain(Store, First)) :-
	store__init(Store0),
	store__new_mutvar(empty, First, Store0, Store).

chain__insert(Thing, Chain0, Chain) :-
	chain__insert(Thing, _Elem, Chain0, Chain).

chain__insert(Thing, Elem, Chain0, Chain) :-
	Chain0 = chain(Store0, First0),
	store__get_mutvar(First0, FirstElem0, Store0, Store1),
	(
		FirstElem0 = empty,
		store__set_mutvar(First0, elem(First0, First0, Thing),
			Store1, Store),
		First = First0,
		Elem = First
	;
		FirstElem0 = elem(Prev, Next, Thing0),
		chain__insert2(Thing, Thing0, First0, Prev, Next,
			First, Elem, Store1, Store)
	),
	Chain = mkchain(Store, First).

:- pred chain__insert2(T, T, handle(T),  handle(T),  handle(T), 
		handle(T),  handle(T), cstore, cstore).
:- mode chain__insert2(in, in, in, in, in, out, out, di, uo) is det.

chain__insert2(NewThing, Thing, This, Prev, Next, First, New,
		Store0, Store) :-
	compare(Res, NewThing, Thing),
	( Res = (<) ->
		store__new_mutvar(elem(Prev, This, NewThing), New,
			Store0, Store1),
		First = New,
		store__set_mutvar(This, elem(New, Next, Thing),
			Store1, Store2),
		store__get_mutvar(Prev, PrevElem, Store2, Store3),
		(
			PrevElem = empty,
			error("chain__insert: prev internal error")
		;
			PrevElem = elem(PPrev, _, PrevThing),
			store__set_mutvar(Prev, elem(PPrev, New, PrevThing),
				Store3, Store)
		)
	;
		First = This,
		chain__insert3(NewThing, This, Next, New, Store0, Store)
	).

:- pred chain__insert3(T, handle(T), handle(T), handle(T), cstore, cstore).
:- mode chain__insert3(in, in, in, out, di, uo) is det.

chain__insert3(NewThing, First, This, New, Store0, Store) :-
	( This = First ->
		store__get_mutvar(This, ThisElem, Store0, Store1),
		(
			ThisElem = empty,
			error("chain__insert: internal error")
		;
			ThisElem = elem(Prev, Next, ThisThing),
			store__new_mutvar(elem(Prev, This, NewThing), New,
				Store1, Store2),
			store__set_mutvar(This, elem(New, Next, ThisThing),
				Store2, Store3),
			store__get_mutvar(Prev, PrevElem, Store3, Store4),
			(
				PrevElem = empty,
				error("chain__insert: another prev internal")
			;
				PrevElem = elem(PPrev, _, PrevThing),
				store__set_mutvar(Prev,
					elem(PPrev, New, PrevThing),
					Store4, Store)
			)
		)
	;
		store__get_mutvar(This, ThisElem, Store0, Store1),
		(
			ThisElem = empty,
			error("chain__insert: another internal error")
		;
			ThisElem = elem(Prev, Next, ThisThing),
			compare(Res, NewThing, ThisThing),
			( Res = (<) ->
				store__new_mutvar(elem(Prev, This, NewThing),
					New, Store1, Store2),
				store__set_mutvar(This,
					elem(New, Next, ThisThing),
					Store2, Store3),
				store__get_mutvar(Prev, PrevElem,
					Store3, Store4),
				(
					PrevElem = empty,
					error("chain__insert: ya prev internal")
				;
					PrevElem = elem(PPrev, _, PrevThing),
					store__set_mutvar(Prev,
						elem(PPrev, New, PrevThing),
						Store4, Store)
				)
			;
				chain__insert3(NewThing, First, Next, New,
					Store1, Store)
			)
		)
	).

chain__first(MFirst, chain(Store0, First), mkchain(Store, First)) :-
	store__get_mutvar(First, FirstElem, Store0, Store),
	(
		FirstElem = empty,
		MFirst = no
	;
		FirstElem = elem(_, _, _),
		MFirst = yes(First)
	).

chain__next(This, Next, chain(Store0, First), chain(Store, First)) :-
	store__get_mutvar(This, ThisElem, Store0, Store),
	(
		ThisElem = empty,
		error("chain__next: no elements!")
	;
		ThisElem = elem(_, Next, _)
	).

chain__prev(This, Prev, chain(Store0, First), chain(Store, First)) :-
	store__get_mutvar(This, ThisElem, Store0, Store),
	(
		ThisElem = empty,
		error("chain__prev: no elements!")
	;
		ThisElem = elem(Prev, _, _)
	).

chain__deref(This, Elem, chain(Store0, First), chain(Store, First)) :-
	store__get_mutvar(This, ThisElem, Store0, Store),
	(
		ThisElem = empty,
		error("chain__deref: empty!")
	;
		ThisElem = elem(_, _, Elem)
	).

chain__update(This, NewThing, chain(Store0, First), chain(Store, First)) :-
	store__get_mutvar(This, ThisElem, Store0, Store1),
	(
		ThisElem = empty,
		error("chain__deref: empty!")
	;
		ThisElem = elem(Prev, Next, _),
		Elem = elem(Prev, Next, NewThing)
	),
	store__set_mutvar(This, Elem, Store1, Store).

:- func mkchain(cstore, handle(T)) = chain(T).
:- mode mkchain(in, in) = uo is det.

mkchain(Store0, First0) = chain(Store, First) :-
	unsafe_promise_unique(Store0, Store),
	unsafe_promise_unique(First0, First).
-- 
ZZ:wq!
^X^C
Thomas Conway               				      conway at cs.mu.oz.au
AD DEUM ET VINUM	  			      Every sword has two edges.