//		S   O   R   T
// Copyright Xerox Corporation 1979

//	A wonderful general-purpose BCPL sorting package

//	E. McCreight
//	last modified October 4, 1977  11:23 PM by McCreight

// The Sort subroutine is invoked with three other subroutines
// and two optional numbers as
// arguments. GetItem is a routine which returns the length
// of a new item (or 0 if no more items exist) which it has
// placed in the buffer passed to it.
// CompareItems returns a positive number if the first item
// is greater, zero if they are equal, and a negative number if
// the second item is greater. PutItem is a routine which will
// write out (or whatever) items after they have been sorted.
// ExpectedItemSize and MaxItemSize, if present, help
// the system partition internal storage in reasonable ways.

get "streams.d"

external
	[ FixedLeft
	GetFixed
	FreeFixed
	CallSwat
	SysErr
	InitializeZone
	Allocate
	Free
	MoveBlock
	OpenFile
	Gets
	Puts
	Resets
	ReadBlock
	WriteBlock
	Closes
	DeleteFile
	DefaultArgs

	sysDisk

	Sort
	DeleteScratch
	]

manifest
	[ NFiles = 3
	DefaultExpItemSize = 10	// Words
	DefaultMaxItemSize = 1000
	AllocNodeOvhd = 1
	infinity = #77777
	]


structure HE:
	[ ItemLen word
	Record word
	]


structure FD:
	[ FileName word
	Stream word
	EndOfRun word
	DummyRuns word
	TotalRuns word
	ItemLen word
	Buffer word
	BHeadIndex word		// First occupied word
	BTailIndex word		// First free word
	Record word
	]


static
	[ SortZone
	SortDisk
	ReleaseZone

	Files
	Level

	ItemIsLeftOver
	LeftoverItem
	LeftoverItemLen

	MaxHeapSize
	RecordSize
	BufferSize

	InputFinished

	Heap
	HeapSize		// end of Heap-sorted part of heap vector
	FirstFreeEnt	// 1+end of unsorted part of heap vector

	MaxItemWords
	OccItemWords

	DeleteScratch
	]


let Sort(GetItem, PutItem, CompareItems, ExpectedItemSize,
		MaxItemSize, SZ, disk; numargs na) be

	[
	DefaultArgs(lv na,-3,DefaultExpItemSize,DefaultMaxItemSize,0,sysDisk)
	SortDisk = disk

	Initialize(SZ, ExpectedItemSize, MaxItemSize)
				// Set up storage structures

	Heap = Allocate(SortZone, MaxHeapSize+1)
	FirstFreeEnt = 1

//	First, fill up the heap as much as possible and
//	sort it.

	LeftoverItem = Allocate(SortZone, RecordSize)
	ItemIsLeftOver = false
	InputFinished = false
	BuildHeap(GetItem, CompareItems)

	if InputFinished then
		[ // One heap's worth was enough! Goodie!

		for i=1 to HeapSize do
			[ let Item = GetHeap(GetItem, CompareItems)
			PutItem(lv (Item>>HE.Record),
				Item>>HE.ItemLen)
			]

		FreeAllocatedStuff()
		return
		]

	let FileName = vec NFiles+1
	FileName!1 = "SORT.SCRATCH1"
	FileName!2 = "SORT.SCRATCH2"
	FileName!3 = "SORT.SCRATCH3"

	for i=1 to NFiles do
		[ let File = Files!i
		File>>FD.FileName = FileName!i

		test i ls NFiles

		ifso	[ File>>FD.Stream = OpenFile(FileName!i,
				ksTypeReadWrite, wordItem,0,0,0,0,0,SortDisk)

			File>>FD.TotalRuns = 1
			File>>FD.DummyRuns = 1
			]

		ifnot	[ File>>FD.TotalRuns = 0
			File>>FD.DummyRuns = 0
			]
		]

	BuildRuns(GetItem, CompareItems)
			// Put runs on input files 1...NFiles-1
			// so that they have Fibonacci relationship

	Free(SortZone, LeftoverItem)
	LeftoverItem = 0

	Free(SortZone, Heap)
	Heap = 0

	if Level gr 1 then
		[ let LastFile = Files!NFiles
		LastFile>>FD.Stream = OpenFile(LastFile>>FD.FileName,
				ksTypeReadWrite, wordItem,0,0,0,0,0,SortDisk)
		]

	let Oops = 0
	Allocate(SortZone, #77777, lv Oops)   // coalesce free space

	for i=1 to NFiles do
		[ let File = Files!i
		File>>FD.Buffer = Allocate(SortZone, BufferSize)
		File>>FD.BHeadIndex = 0
		File>>FD.BTailIndex = 0
		]

//	Now carry out merge passes until the level has returned
//	to zero.

	DeleteScratch = false	// scratch file may not exist
	until Level eq 0 do
		[ MergePass(CompareItems, PutItem)
			// also cycles the files afterward if Level>1

		Level = Level-1

		if Level eq 1 then
			[ // Output will go to the PutItem routine
			Closes((Files!NFiles)>>FD.Stream)
			DeleteScratch = true
				// it exists, and we'll delete it
				// unless our caller's PutItem
				// minion toggles DeleteScratch
			]
		]

	for i=1 to NFiles-1 do
		[ Closes((Files!i)>>FD.Stream)
		DeleteFile((Files!i)>>FD.FileName,0,0,0,0,SortDisk)
		]

	if DeleteScratch then
		DeleteFile((Files!NFiles)>>FD.FileName,0,0,0,0,SortDisk)

	FreeAllocatedStuff()
	]



and Initialize(SZ, ExpectedItemSize, MaxItemSize) be

	[ test SZ eq 0

	ifso	[ let BlockSize = FixedLeft()-1000
		if UGR(BlockSize, #77777) then
			BlockSize = #77777
		SortZone = GetFixed(BlockSize)
		InitializeZone(SortZone, BlockSize, SysErr, 0)
		ReleaseZone = true
		]

	ifnot	[ SortZone = SZ
		ReleaseZone = false
		]

	Files = Allocate(SortZone, NFiles+1)

	for i=1 to NFiles do
		[ let File = Allocate(SortZone, size FD/16)
		Files!i = File
		File>>FD.Buffer = 0
		File>>FD.Record = 0
		]

	let BlockSize = 0		// find the biggest single block
	Allocate(SortZone, #77777, lv BlockSize)

	BufferSize = (BlockSize-200)/NFiles
	RecordSize = BufferSize
	if RecordSize gr MaxItemSize then
		RecordSize = MaxItemSize
	MaxHeapSize = (BlockSize-(RecordSize+200))/(ExpectedItemSize+3)
	MaxItemWords = BlockSize-MaxHeapSize-RecordSize-200
	OccItemWords = 0
	]


and FreeAllocatedStuff() be

	[ for i=1 to NFiles do
		[ let File = Files!i
		if File>>FD.Buffer ne 0 then
			Free(SortZone, File>>FD.Buffer)
		if File>>FD.Record ne 0 then
			Free(SortZone, File>>FD.Record)
		Free(SortZone, File)
		]

	Free(SortZone, Files)

	if Heap ne 0 then Free(SortZone, Heap)
	if LeftoverItem ne 0 then Free(SortZone, LeftoverItem)

	if ReleaseZone then
		FreeFixed(SortZone)
	]


and BuildRuns(GetItem, CompareItems) be

	[ Level = 1
	let j = 1

//	Continue reading and sorting, alternating in Fibonacci sequence,
//	until the input is exhausted.

	    [ let File = Files!j

	    if Level gr 1 then
		Puts(File>>FD.Stream, -1)	// End-of-run marker

	let Item = GetHeap(GetItem, CompareItems)
	while Item ne 0 do
		[ let ItemLen = Item>>HE.ItemLen
		Puts(File>>FD.Stream, ItemLen)
		WriteBlock(File>>FD.Stream,
			lv (Item>>HE.Record), ItemLen)
		Free(SortZone, Item)
		OccItemWords = OccItemWords-
				ItemLen-
				(offset HE.Record/16)-
				AllocNodeOvhd

		Item = GetHeap(GetItem, CompareItems)
		]

	    let DummyRuns = File>>FD.DummyRuns-1
	    File>>FD.DummyRuns = DummyRuns

	    if InputFinished & (FirstFreeEnt eq 1) then break

	    test DummyRuns ls (Files!(j+1)>>FD.DummyRuns)

	    ifso	j = j+1

	    ifnot	[ j = 1

		if DummyRuns eq 0 then

			[ Level = Level+1
			let A = (Files!1)>>FD.TotalRuns
			for i=1 to NFiles-1 do
				[ let LFile = Files!i
				let NT = A+(Files!(i+1))>>
					FD.TotalRuns
				LFile>>FD.DummyRuns = NT-
					    LFile>>FD.TotalRuns
				LFile>>FD.TotalRuns = NT
				]
			]
		]

	    BuildHeap(GetItem, CompareItems)
	    ] repeat

	for i=1 to NFiles-1 do
		[ Puts((Files!i)>>FD.Stream, -1)	// end-of-run
		Resets((Files!i)>>FD.Stream)
		]
	]


and MergePass(CompareItems, PutItem) be

	[ let OFile = Files!NFiles
	let LastFile = Files!(NFiles-1)

	let RunsThisPass = LastFile>>FD.TotalRuns
	let DummiesThisPass = infinity
	for i=1 to NFiles-1 do
		if (Files!i)>>FD.DummyRuns ls DummiesThisPass then
			DummiesThisPass = (Files!i)>>FD.DummyRuns

	OFile>>FD.TotalRuns = RunsThisPass
	OFile>>FD.DummyRuns = DummiesThisPass
	for i=1 to NFiles-1 do
		[ (Files!i)>>FD.TotalRuns =
			(Files!i)>>FD.TotalRuns-RunsThisPass
		(Files!i)>>FD.DummyRuns =
			(Files!i)>>FD.DummyRuns-DummiesThisPass
		]

	for RunNo=DummiesThisPass+1 to RunsThisPass do
			MergeRun(OFile, LastFile,
				CompareItems, PutItem, RunNo)

	if Level gr 1 then
		[ FlushBuffer(OFile)

		for i=NFiles-1 to NFiles do
			[ let File = Files!i
			Resets(File>>FD.Stream)
			File>>FD.BHeadIndex = 0
			File>>FD.BTailIndex = 0
			]

//		Cycle the files.

		let T = Files!NFiles
		for i=NFiles-1 to 1 by -1 do Files!(i+1) = Files!i
		Files!1 = T
		]
	]


and BuildHeap(GetItem, CompareItems) be

	[ HeapSize = 0
	MaintainHeap(GetItem, CompareItems)

	HeapSize = FirstFreeEnt-1

	let L = (HeapSize/2)+1

	while L gr 1 do
		[ L = L-1
		SiftDown(L, Heap!L, CompareItems)
		]
	]


and MaintainHeap(GetItem, CompareItems) be

	[ // Fill the heap as full as possible

	if InputFinished then return

	while FirstFreeEnt le MaxHeapSize do
		[ // Try adding another heap element

		unless ItemIsLeftOver do
			[ LeftoverItemLen =
				GetItem(LeftoverItem, RecordSize)

			if LeftoverItemLen gr RecordSize then
				CallSwat("Record too long.")

			unless LeftoverItemLen gr 0 do
				[ InputFinished = true
				return
				]
			]

		if OccItemWords ge MaxItemWords then
			[ ItemIsLeftOver = true
			return
			]

		let Oops = 0
		let Item = Allocate(SortZone, LeftoverItemLen+
				(offset HE.Record/16), lv Oops)
		if Oops ne 0 then
			[ MaxItemWords = OccItemWords-100
			ItemIsLeftOver = true
			return
			]

		OccItemWords = OccItemWords+
				LeftoverItemLen+
				(offset HE.Record/16)+
				AllocNodeOvhd

		Item>>HE.ItemLen = LeftoverItemLen
		MoveBlock(lv (Item>>HE.Record) ,LeftoverItem,
					LeftoverItemLen)

		Heap!FirstFreeEnt = Heap!(HeapSize+1)
		FirstFreeEnt = FirstFreeEnt+1
		Heap!(HeapSize+1) = Item

		ItemIsLeftOver = false

		if HeapSize gr 0 &
			CompareItems(lv (Item>>HE.Record),
				lv ((Heap!1)>>HE.Record)) ge 0 then

			[ HeapSize = HeapSize+1
			SiftUp(CompareItems)
			]
		]
	]


and GetHeap(GetItem, CompareItems) = valof

	[ if HeapSize eq 0 then resultis 0

	MaintainHeap(GetItem, CompareItems)

	let Item = Heap!1

	SiftDown(1, Heap!HeapSize, CompareItems)

	Heap!HeapSize = Heap!(FirstFreeEnt-1)
	HeapSize = HeapSize-1
	FirstFreeEnt = FirstFreeEnt-1

	resultis Item
	]


and SiftUp(CompareItems) be

	[ let J = HeapSize
	let K = Heap!HeapSize

	let I = J rshift 1

	while I gr 0 do
		[ if CompareItems(lv ((Heap!I)>>HE.Record),
				lv (K>>HE.Record)) le 0 then
					break

		Heap!J = Heap!I
		J = I
		I = J rshift 1
		]

	Heap!J = K
	]


and SiftDown(L, K, CompareItems) be

	[ let J = L
	let I = nil

		[ I = J
		J = J+J

		if J gr HeapSize then break

		if J ls HeapSize then
			if CompareItems(lv ((Heap!J)>>HE.Record),
				lv ((Heap!(J+1))>>HE.Record)) gr 0
				then
				J = J+1

		if CompareItems(lv (K>>HE.Record),
				lv ((Heap!J)>>HE.Record)) le 0
				then break

		Heap!I = Heap!J
		] repeat

	Heap!I = K
	]


and MergeRun(OFile, LastFile, CompareItems, PutItem, RunNo) be

	[ // Process a run. Fill up the applicable records.

	for i=1 to NFiles-1 do
		[ let File = Files!i

		test File>>FD.DummyRuns eq 0

		ifnot	[ File>>FD.DummyRuns = File>>FD.DummyRuns-1
			File>>FD.EndOfRun = true
			]

		ifso	ReadRecord(File)
		]

	while true do
		[ let SR = 0	// selected record (which file is it from)
		for i=1 to NFiles-1 do
			if (not ((Files!i)>>FD.EndOfRun)) &
			    (SR eq 0 %
			    (CompareItems((Files!i)>>FD.Record,
					(Files!SR)>>FD.Record) ls 0))
				then SR = i

		if SR eq 0 then break

		let File = (Files!SR)
		let ItemLen = File>>FD.ItemLen

		test Level eq 1

		ifnot	WriteRecord(OFile, ItemLen,
					File>>FD.Record)
		ifso	PutItem(File>>FD.Record, ItemLen,
				OFile>>FD.FileName)

		File>>FD.Record = 0	// for cleanup guy

		ReadRecord(File)
		]

	if Level gr 1 then
		WriteRecord(OFile, -1)
				// End-of-run marker

	]


and ReadRecord(File) = valof

	[ if File>>FD.BHeadIndex eq File>>FD.BTailIndex then
		FillBuffer(File)

	let HeadIndex = File>>FD.BHeadIndex
	let ItemLen = (File>>FD.Buffer)!HeadIndex
	HeadIndex = HeadIndex+1
	File>>FD.BHeadIndex = HeadIndex

	if ItemLen ls 0 then
		[ File>>FD.EndOfRun = true
		resultis false
		]

	if HeadIndex+ItemLen gr File>>FD.BTailIndex then
		FillBuffer(File)

	HeadIndex = File>>FD.BHeadIndex
	File>>FD.Record = lv ((File>>FD.Buffer)!HeadIndex)
	File>>FD.BHeadIndex = HeadIndex+ItemLen
	File>>FD.ItemLen = ItemLen
	File>>FD.EndOfRun = false
	resultis true
	]


and FillBuffer(File) be

	[ let Buffer = File>>FD.Buffer
	let HeadIndex = File>>FD.BHeadIndex
	let WordsInBuffer = File>>FD.BTailIndex-HeadIndex

	if WordsInBuffer gr 0 then
		MoveBlock(Buffer, lv (Buffer!HeadIndex),
					WordsInBuffer)

	let NewWords = ReadBlock(File>>FD.Stream,
				lv (Buffer!WordsInBuffer),
				BufferSize-WordsInBuffer)

	File>>FD.BHeadIndex = 0
	File>>FD.BTailIndex = WordsInBuffer+NewWords
	]


and WriteRecord(File, ItemLen, Item) be

	[ let Buffer = File>>FD.Buffer
	let TailIndex = File>>FD.BTailIndex
	if TailIndex+((ItemLen ls 0)?
			1,
			ItemLen+1) gr BufferSize then

		[ FlushBuffer(File)
		TailIndex = File>>FD.BTailIndex
		]

	Buffer!TailIndex = ItemLen
	TailIndex = TailIndex+1

	if ItemLen ge 0 then
		[ MoveBlock(lv (Buffer!TailIndex), Item, ItemLen)
		TailIndex = TailIndex+ItemLen
		]

	File>>FD.BTailIndex = TailIndex
	]


and FlushBuffer(File) be

	[ WriteBlock(File>>FD.Stream, File>>FD.Buffer,
			File>>FD.BTailIndex)

	File>>FD.BTailIndex = 0
	]


and UGR(X, Y) =

	table	[ #106432;	//	SGTU	0,1
		#102461;	//	MKZERO	0,0,SKP
		#102000;	//	MKMINUSONE	0,0
		#1401		//	JMP	1,3
 		] (X, Y)