note
	description: "[
		Quicksort according to Lamport/Meyer.
		The Lampsort algorithm is a simple loop; it does not use recursion, 
		but relies on an interesting data structure, a set of intervals. 
		It is hardly more difficult to understand, 
		and hardly shorter, than the traditional recursive version.
		the recursive version, and its parallelized variants, 
		are only examples of possible implementations
	]"
	author: "JSO"
	date: "$Date$"
	revision: "$Revision$"

class 
	LAMPSORT [G -> COMPARABLE]

create 
	make

feature {NONE} -- Initialization

	default_create
			-- Process instances of classes with no creation clause.
			-- (Default: do nothing.)
			-- (from ANY)
		do
		end
	
feature -- Access

	generating_type: TYPE [detachable LAMPSORT [G]]
			-- Type of current object
			-- (type of which it is a direct instance)
			-- (from ANY)
		external
			"built_in"
		ensure -- from ANY
			generating_type_not_void: Result /= Void
		end

	generator: STRING_8
			-- Name of current object's generating class
			-- (base class of the type of which it is a direct instance)
			-- (from ANY)
		external
			"built_in"
		ensure -- from ANY
			generator_not_void: Result /= Void
			generator_not_empty: not Result.is_empty
		end
	
feature -- Comparison

	frozen deep_equal (a: detachable ANY; b: like arg #1): BOOLEAN
			-- Are a and b either both void
			-- or attached to isomorphic object structures?
			-- (from ANY)
		do
			if a = Void then
				Result := b = Void
			else
				Result := b /= Void and then a.is_deep_equal (b)
			end
		ensure -- from ANY
			instance_free: class
			shallow_implies_deep: standard_equal (a, b) implies Result
			both_or_none_void: (a = Void) implies (Result = (b = Void))
			same_type: (Result and (a /= Void)) implies (b /= Void and then a.same_type (b))
			symmetric: Result implies deep_equal (b, a)
		end

	frozen equal (a: detachable ANY; b: like arg #1): BOOLEAN
			-- Are a and b either both void or attached
			-- to objects considered equal?
			-- (from ANY)
		do
			if a = Void then
				Result := b = Void
			else
				Result := b /= Void and then a.is_equal (b)
			end
		ensure -- from ANY
			instance_free: class
			definition: Result = (a = Void and b = Void) or else ((a /= Void and b /= Void) and then a.is_equal (b))
		end

	frozen is_deep_equal (other: LAMPSORT [G]): BOOLEAN
			-- Are Current and other attached to isomorphic object structures?
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
		external
			"built_in"
		ensure -- from ANY
			shallow_implies_deep: standard_is_equal (other) implies Result
			same_type: Result implies same_type (other)
			symmetric: Result implies other.is_deep_equal (Current)
		end

	is_equal (other: LAMPSORT [G]): BOOLEAN
			-- Is other attached to an object considered
			-- equal to current object?
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
		external
			"built_in"
		ensure -- from ANY
			symmetric: Result implies other ~ Current
			consistent: standard_is_equal (other) implies Result
		end

	frozen standard_equal (a: detachable ANY; b: like arg #1): BOOLEAN
			-- Are a and b either both void or attached to
			-- field-by-field identical objects of the same type?
			-- Always uses default object comparison criterion.
			-- (from ANY)
		do
			if a = Void then
				Result := b = Void
			else
				Result := b /= Void and then a.standard_is_equal (b)
			end
		ensure -- from ANY
			instance_free: class
			definition: Result = (a = Void and b = Void) or else ((a /= Void and b /= Void) and then a.standard_is_equal (b))
		end

	frozen standard_is_equal (other: LAMPSORT [G]): BOOLEAN
			-- Is other attached to an object of the same type
			-- as current object, and field-by-field identical to it?
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
		external
			"built_in"
		ensure -- from ANY
			same_type: Result implies same_type (other)
			symmetric: Result implies other.standard_is_equal (Current)
		end
	
feature -- Status report

	conforms_to (other: ANY): BOOLEAN
			-- Does type of current object conform to type
			-- of other (as per Eiffel: The Language, chapter 13)?
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
		external
			"built_in"
		end

	same_type (other: ANY): BOOLEAN
			-- Is type of current object identical to type of other?
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
		external
			"built_in"
		ensure -- from ANY
			definition: Result = (conforms_to (other) and other.conforms_to (Current))
		end
	
feature -- Duplication

	frozen clone (other: detachable ANY): like other
		obsolete "Use `twin' instead. [2017-05-31]"
			-- Void if other is void; otherwise new object
			-- equal to other
			--
			-- For non-void other, clone calls copy;
			-- to change copying/cloning semantics, redefine copy.
			-- (from ANY)
		do
			if other /= Void then
				Result := other.twin
			end
		ensure -- from ANY
			instance_free: class
			equal: Result ~ other
		end

	copy (other: LAMPSORT [G])
			-- Update current object using fields of object attached
			-- to other, so as to yield equal objects.
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
			type_identity: same_type (other)
		external
			"built_in"
		ensure -- from ANY
			is_equal: Current ~ other
		end

	frozen deep_clone (other: detachable ANY): like other
		obsolete "Use `deep_twin' instead. [2017-05-31]"
			-- Void if other is void: otherwise, new object structure
			-- recursively duplicated from the one attached to other
			-- (from ANY)
		do
			if other /= Void then
				Result := other.deep_twin
			end
		ensure -- from ANY
			instance_free: class
			deep_equal: deep_equal (other, Result)
		end

	frozen deep_copy (other: LAMPSORT [G])
			-- Effect equivalent to that of:
			--		copy (other . deep_twin)
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
		do
			copy (other.deep_twin)
		ensure -- from ANY
			deep_equal: deep_equal (Current, other)
		end

	frozen deep_twin: LAMPSORT [G]
			-- New object structure recursively duplicated from Current.
			-- (from ANY)
		external
			"built_in"
		ensure -- from ANY
			deep_twin_not_void: Result /= Void
			deep_equal: deep_equal (Current, Result)
		end

	frozen standard_clone (other: detachable ANY): like other
		obsolete "Use `standard_twin' instead. [2017-05-31]"
			-- Void if other is void; otherwise new object
			-- field-by-field identical to other.
			-- Always uses default copying semantics.
			-- (from ANY)
		do
			if other /= Void then
				Result := other.standard_twin
			end
		ensure -- from ANY
			instance_free: class
			equal: standard_equal (Result, other)
		end

	frozen standard_copy (other: LAMPSORT [G])
			-- Copy every field of other onto corresponding field
			-- of current object.
			-- (from ANY)
		require -- from ANY
			other_not_void: other /= Void
			type_identity: same_type (other)
		external
			"built_in"
		ensure -- from ANY
			is_standard_equal: standard_is_equal (other)
		end

	frozen standard_twin: LAMPSORT [G]
			-- New object field-by-field identical to other.
			-- Always uses default copying semantics.
			-- (from ANY)
		external
			"built_in"
		ensure -- from ANY
			standard_twin_not_void: Result /= Void
			equal: standard_equal (Result, Current)
		end

	frozen twin: LAMPSORT [G]
			-- New object equal to Current
			-- twin calls copy; to change copying/twinning semantics, redefine copy.
			-- (from ANY)
		external
			"built_in"
		ensure -- from ANY
			twin_not_void: Result /= Void
			is_equal: Result ~ Current
		end
	
feature -- Basic operations

	frozen as_attached: attached LAMPSORT [G]
		obsolete "Remove calls to this feature. [2017-05-31]"
			-- Attached version of Current.
			-- (Can be used during transitional period to convert
			-- non-void-safe classes to void-safe ones.)
			-- (from ANY)
		do
			Result := Current
		end

	frozen default: detachable LAMPSORT [G]
			-- Default value of object's type
			-- (from ANY)
		do
		end

	frozen default_pointer: POINTER
			-- Default value of type POINTER
			-- (Avoid the need to write p.default for
			-- some p of type POINTER.)
			-- (from ANY)
		do
		ensure -- from ANY
			instance_free: class
		end

	default_rescue
			-- Process exception for routines with no Rescue clause.
			-- (Default: do nothing.)
			-- (from ANY)
		do
		end

	frozen do_nothing
			-- Execute a null action.
			-- (from ANY)
		do
		ensure -- from ANY
			instance_free: class
		end
	
feature 

	a: ARRAY [G]

	lampsort (i, j: INTEGER_32)
		require
				a.lower <= i
				i <= j
				j <= a.upper
		local
			l_intvl: INTEGER_INTERVAL
			intervals: SET [INTEGER_INTERVAL]
		do
			from
				create l_intvl.make (a.lower, a.upper)
				create intervals.make_empty
				intervals.extend (l_intvl)
			invariant
					True
			until
				intervals.is_empty
			loop
				intervals.choose_item
				picked := intervals.item
				intervals.remove_item
				if picked.count > 1 then
					partition (picked.lower, picked.upper)
					intervals.extend (picked.lower |..| pivot1)
					intervals.extend (pivot2 |..| picked.upper)
				end
			end
		end

	make (l_a: like a)
		do
			a := l_a
			create picked.make (0, -1)
		ensure
				a = l_a
		end

	partition (i, j: INTEGER_32)
		require
				a.lower <= i
				i <= j
				j <= a.upper
		local
			m, n, k: INTEGER_32
			x: G
		do
			from
				x := a [i]
				n := j + 1
				m := i
				k := m
			invariant
					i <= m and m <= k and k <= n and n <= j + 1
					across
						i |..| (m - 1) as it
					all
						a [it.item] < x
					end
					across
						m |..| (k - 1) as kt
					all
						a [kt.item] = x
					end
					across
						n |..| j as jt
					all
						x < a [jt.item]
					end
			variant
					n - k
			until
				k = n
			loop
				if a [k] = x then
					k := k + 1
				elseif a [k] < x then
					swap (m, k)
					m := m + 1
					k := k + 1
				else
					check
							x < a [k]
					end
					swap (k, n - 1)
					n := n - 1
				end
			end
			pivot1 := m - 1
			pivot2 := n
		ensure
				i - 1 <= pivot1 and pivot1 <= j
				i <= pivot2 and pivot2 <= j + 1
				permutation (a, a.deep_twin)
				across
					i |..| pivot1 as it
				all
					across
						(pivot1 + 1) |..| j as jt
					all
						a [it.item] <= a [jt.item]
					end
				end
				across
					i |..| (pivot2 - 1) as it
				all
					across
						pivot2 |..| j as jt
					all
						a [it.item] <= a [jt.item]
					end
				end
		end

	picked: INTEGER_INTERVAL

	pivot1: INTEGER_32

	pivot2: INTEGER_32

	sort
			-- Lampsort version of quicksort for array a
		do
			lampsort (a.lower, a.upper)
		ensure
				across
					a.lower |..| (a.upper - 1) as k
				all
					a [k.item] <= a [k.item + 1]
				end
				permutation (old a.deep_twin, a)
		end

	sort2
			-- recursive quicksort
		do
			sort_recursive (a.lower, a.upper)
		ensure
				across
					a.lower |..| (a.upper - 1) as k
				all
					a [k.item] <= a [k.item + 1]
				end
				permutation (old a.deep_twin, a)
		end

	sort_recursive (i, j: INTEGER_32)
		require
				a.lower <= i
				i <= j + 1
				j <= a.upper
		do
			if i < j then
				partition (i, j)
				sort_recursive (i, pivot1)
				sort_recursive (pivot2, j)
			end
		end

	swap (m, n: INTEGER_32)
		require
				a.lower <= m
				m <= n
				n <= a.upper
		local
			temp: G
		do
			temp := a [m]
			a [m] := a [n]
			a [n] := temp
		ensure
				a [m] ~ old a [n] and a [n] ~ old a [m]
		end
	
feature -- Output

	Io: STD_FILES
			-- Handle to standard file setup
			-- (from ANY)
		once
			create Result
			Result.set_output_default
		ensure -- from ANY
			instance_free: class
			io_not_void: Result /= Void
		end

	out: STRING_8
			-- New string containing terse printable representation
			-- of current object
			-- (from ANY)
		do
			Result := tagged_out
		ensure -- from ANY
			out_not_void: Result /= Void
		end

	print (o: detachable ANY)
			-- Write terse external representation of o
			-- on standard output.
			-- (from ANY)
		do
			if o /= Void then
				Io.put_string (o.out)
			end
		ensure -- from ANY
			instance_free: class
		end

	frozen tagged_out: STRING_8
			-- New string containing terse printable representation
			-- of current object
			-- (from ANY)
		external
			"built_in"
		ensure -- from ANY
			tagged_out_not_void: Result /= Void
		end
	
feature -- Platform

	Operating_environment: OPERATING_ENVIRONMENT
			-- Objects available from the operating system
			-- (from ANY)
		once
			create Result
		ensure -- from ANY
			instance_free: class
			operating_environment_not_void: Result /= Void
		end
	
feature {NONE} -- Retrieval

	frozen internal_correct_mismatch
			-- Called from runtime to perform a proper dynamic dispatch on correct_mismatch
			-- from MISMATCH_CORRECTOR.
			-- (from ANY)
		local
			l_msg: STRING_8
			l_exc: EXCEPTIONS
		do
			if attached {MISMATCH_CORRECTOR} Current as l_corrector then
				l_corrector.correct_mismatch
			else
				create l_msg.make_from_string ("Mismatch: ")
				create l_exc
				l_msg.append (generating_type.name)
				l_exc.raise_retrieval_exception (l_msg)
			end
		end
	
feature -- array queries

	permutation (a1, a2: like a): BOOLEAN
		do
			if a1.count = a2.count then
				Result := across
					a1 as it
				all
					a1.occurrences (it.item) = a2.occurrences (it.item)
				end
			else
				Result := False
			end
		ensure
				Result implies a1.count = a2.count and then across
					a1 as it
				all
					a1.occurrences (it.item) = a2.occurrences (it.item)
				end
				not Result implies a1.count /= a2.count or else (across
					a1 as it
				some
					a1.occurrences (it.item) /= a2.occurrences (it.item)
				end)
		end
	
invariant
		-- from ANY
	reflexive_equality: standard_is_equal (Current)
	reflexive_conformance: conforms_to (Current)

end -- class LAMPSORT

Generated by ISE EiffelStudio