title	SORT Testprogramm fuer CP/M
	name	('SORT')
	maclib	base80

; File : SORT.MAC

; Programmaufruf mit

;	SORT file typ [pos,len]

; Mit	"file"	ist die zu sortierende Datei
;	"pos"	ist die Position, an der die Sortierung started
;	"len"	ist dir Laenge des zu sortierenden Elementes
;	"typ"	ist die zu waehlende Sortierart

; Aktuell implementierte Sortierarten sind:

;	LINEAR	BINARY
;	BUBBLE	SHAKE
;	HEAP	QUICK

.gettod	equ	105

; ===== Externe Referenzen ====

	ext	open,close,conout,fillin,string,crlf
	ext	delete,create,rdbfp,decin,multip,decout
	ext	skpblk,emplin,puteof,comp3,wrfcb
	ext	c16fl,fldiv,flform

	ext	shake,quick,linear,heap,bubble,binary

	entry	$memry,curline,ptr.1,ptr.2,ptr.3,ptr.4,ptr.5
	entry	@swap,swap,ass1,ass2,ass3,ass4,cmpidx,cmpxdm
	entry	begtim,endtim

; ===== Hier geht es los =====

	ld	sp,mystack	; Lokalen Stack laden
	call	iniptr
	ld	hl,fcbnm2
	ld	a,(hl)
	cp	' '		; Test, ob legale Sortierart
	jp	z,help
	cp	'['
	jp	z,help
	ld	de,@sort
	ld	bc,.fname
	ldir			; Dateinamen umpacken
	ld	de,fcb
	call	open		; Test, ob Sortierdatei vorhanden
	jp	c,filerr	; Fehler falls nicht
	ex	de,hl
	ld	de,SORTfcb
	ld	bc,.fdrv+.fname
	ldir			; Sortiernamen umpacken
	call	getpara		; Parameter laden
	ld	de,$read
	call	string
	call	read$once	; Datei einlesen
	ld	hl,(curline)
	dec	hl		; Test ob nur eine Zeile
	ld	a,l
	or	h
	ld	de,$ill
	jp	z,c.err
	ld	a,(p.def)	; Test Parameter
	cp	true
	jr	nz,para.def
	ld	hl,1
	ld	(pos),hl	; Defaultwert fuer POS setzen
para.def:
	ld	a,(l.def)
	cp	true
	jr	nz,paraset
	ld	hl,(max)
	ld	de,(pos)
	and	a
	sbc	hl,de
	inc	hl
	ld	(length),hl	; Defaultwert fuer LENGTH setzen
paraset:
	call	tstpara		; Test Parameter
	ld	hl,(curline)
	ld	de,(max)
	call	multip		; Benoetigten Speicher bereitstellen
	jr	c,ovlERR
	ld	de,($memry)
	add	hl,de
	ex	de,hl
	ld	hl,(bdos+1)
	or	a
	sbc	hl,de		; Test ob genug Speicher
	jr	c,ovlERR
	ld	de,fcb
	call	close
	call	open		; Sortierdatei erneut oeffnen
	ld	a,reclng
	ld	(rdbfp),a
	ld	de,$reread
	call	string
	call	read$twice	; Sortierdatei lesen
	ld	de,$sort
	call	string
	call	sort		; Sortierung durchfuehren
	ld	de,SORTfcb
	ld	(wrfcb),de	; FCB zum Schreiben festlegen
	call	delete
	call	create		; Datei anlegen
	ld	de,$create
	jr	c,c.err
	call	iniptr
	ld	de,$wrt
	call	string
	ld	hl,(curline)
	push	hl		; Zeilenzahl retten
	call	rewrite		; Daten in neue Datei schreiben
	ld	de,$rdy		; Tell ready
	call	string
	pop	hl
	ld	(curline),hl
	call	tell$time	; Ausgabe der benoetgten Zeit
	jp	warm
help:
	ld	de,$help
	call	string
	jp	warm
ovlERR:
	ld	de,$ovl
	jr	c.err
;
; Test ob eingelesene Zeile gueltig ist
;
check:
	jr	z,chk.cr	; .. testen ob Zeile leer
	ld	b,a		; Laenge retten
.check:
	ld	a,(hl)
	cp	' '		; Test ob Zeichen gueltig
	jr	c,invalid
	cp	'~'+1
	jr	nc,invalid
	inc	hl
	djnz	.check
chk.cr:
	ld	a,(hl)		; Test gueltiges Endzeichen
	cp	cr
	ret	z
	ld	de,$nl
	jr	c.err
invalid:
	push	af
	ld	a,'^'
	jr	c,.ctrl
	ld	a,'*'
.ctrl:
	call	conout		; Anzeige, dass Zeichen ungueltig
	pop	af
	ld	a,(hl)
	jr	c,..ctrl
	sub	080h-'@'
..ctrl:
	add	a,'@'
	call	conout
	ld	a,' '
	call	conout
	ld	de,$invalid
	jr	c.err
filerr:
	ld	de,$filerr
c.err:
	push	de
	ld	de,$ERR		; Fehler ausgeben
	call	string
	pop	de
	call	string
	call	crlf
	jp	warm
;
; Werte fuer POS und LENGTH laden
;
getpara:
	ld	hl,dma
	ld	c,(hl)
	ld	b,0
	inc	hl
	ld	a,'['		; Optionszeichen finden
	cpir
	jr	nz,pardef
	ex	de,hl
	ld	l,','
	ld	bc,p.def
	call	get.num		; POS holen
	ld	(pos),hl
	inc	de
	ld	l,']'
	ld	bc,l.def
	call	get.num		; .. LENGTH holen
	ld	(length),hl
	ret
pardef:
	ld	a,true
	ld	(p.def),a	; Default setzen
	ld	(l.def),a
	ret
get.num:
	ld	a,(de)		; Test Default
	cp	'*'
	jr	nz,dec.get
	ld	a,true
	ld	(bc),a		; Marke setzen
	inc	de
	ld	a,(de)
	cp	l		; Test gueltiger Trenner
	ret	z
	jr	parERR
dec.get:
	ld	b,l
	call	decin		; Dezimalwert holen
	ret	nc
parERR:
	ld	de,$par
	jr	c.err
;
; Test ob Parameter ok
;
tstpara:
	ld	hl,(pos)
	ld	a,l
	or	h		; Test > 0
	jr	z,parERR
	ld	e,l
	ld	d,h
	call	..max		; Test > max
	dec	de
	ld	(pos),de	; Startwert fixieren
	ld	hl,(length)
	add	hl,de
..max:
	ld	bc,(max)
	inc	bc
	or	a
	sbc	hl,bc		; Test max
	ret	c
	jr	parERR
;
; Datei einlesen, maximale Laenge bestimmen
;
read$once:
	ld	b,0
	ld	de,my_line	; Zeile lesen
	call	fillin	
	ret	c		; Test Dateiende
	sub	2
	jr	z,read$once	; Leere Zeile ignorieren
	ld	e,a
	ld	d,0
	ld	hl,my_line+1
	call	check		; Test ob Zeichen gueltig
	ld	hl,(curline)
	inc	hl		; Zeilenzahl erhoehen
	ld	(curline),hl
	ld	hl,(max)	; Vielleicht ist diese Laenge MAX
	and	a
	sbc	hl,de
	jr	nc,read$once
	ld	(max),de	; Speichern falls ja
	jr	read$once
;
; Datei einlesen mit fester Laenge
;
read$twice:
	ld	b,0
	ld	de,my_line	; Zeile lesen
	call	fillin	
	ret	c		; Test Dateiende
	sub	2
	jr	z,read$twice	; Leere Zeile ignorieren
	ld	c,a
	ld	b,0
	push	bc
	ld	hl,(curptr)	; Adresse holen
	push	hl
	ld	e,l
	ld	d,h
	inc	de
	ld	bc,(max)
	dec	bc
	ld	(hl),' '	; Zeile mit mit Leerzeichen beschreiben
	ldir
	ld	(curptr),de
	pop	de
	pop	bc
	ld	hl,my_line+1
	ldir			; Eingelesene Zeile umlopieren
	jr	read$twice
;
; Sortierte Elemente in Datei schreiben
;
rewrite:
	ld	hl,(curptr)
	push	hl
	ld	bc,(max)
	add	hl,bc		; Zeiger auf Ende des Elementes
	ld	(curptr),hl
nxt$wrt:
	dec	hl
	ld	a,(hl)
	cp	' '		; Leerzeichen ignorieren
	jr	nz,ok$write
	dec	bc
	ld	a,b
	or	c
	jr	nz,nxt$wrt
	pop	hl
	ld	de,my_line+1
cls$wrt:
	ld	hl,wrt$nl
	ld	bc,3
	ldir			; Ende setzen
	ld	b,0
	ld	de,my_line+1
	call	emplin		; Zeile schreiben
	jr	c,fileERR
	ld	hl,(curline)
	dec	hl
	ld	(curline),hl
	ld	a,l
	or	h		; Test ob Ende
	jr	nz,rewrite
	call	puteof		; Letzen Rekord schreiben
	ld	de,SORTfcb
	call	nc,close
	ret	nc
fileERR:
	ld	de,delete	; Datei loeschen im Fehlerfall
	ld	de,$fileERR
	jp	c.err
ok$write:
	pop	hl
	ld	de,my_line+1
	ldir			; Zeile umkopierem
	jr	cls$wrt
iniptr:
	ld	hl,($memry)
	ld	(curptr),hl
	ret

; ***** HILFSROUTINEN FUER DIE SORTIERROUTINEN *****
;
; Die Vergleichsroutinen
; AUS	  <	NoCarry, NoZero
; 	  >	Carry, NoZero
; 	  =	NoCarry, Zero
; 	  >=	Carry, NoZero ODER NoCarry, Zero
; 	  <=	NoCarry
;
; Vergleich DUMMY : DATA(HL)
;
cmpxdm:
	call	ptr		; Wirkliche Adresse holen
	ld	de,dummy	; Puffer setzen
	jr	..comp
;
; Vergleich DATA(HL) : DATA(HL+1)
;
cmpidx:
	call	consecutive
..comp:
	ld	bc,(pos)
	push	bc
	add	hl,bc		; Teilkette positionieren
	ex	de,hl
	pop	bc
	add	hl,bc		; .. die zweite Kette
	ld	bc,(max)
	call	comp3		; Vergleich
	ret
;
; Zwei Elemente austauschen
; EIN	Register HL haelt Zeiger 1
; 	Register DE haelt Zeiger 2
; Fuehrt aus:
;	DUMMY    := DATA(HL)
;	DATA(HL) := DATA(DE)
;	DATA(DE) := DUMMY
;
swap:
	ld	bc,dummy
	jr	.swap
@swap:
	ld	bc,.dummy
.swap:
	push	bc
	push	bc
	call	ptr		; Adresse holen
	pop	bc
	push	hl
	push	de
	ld	e,c		; Dummy laden
	ld	d,b
	call	set$		; Elemente tauschen
	pop	hl
	call	ptr
	pop	de
	push	hl
	call	set$
	pop	de
	pop	hl
	jr	set$
;
; Die Zuordnungsroutinen
;
; ASS1
; EIN	Register HL haelt Zeiger
; Fuehrt aus:
;	DUMMY := DATA(HL)
;
ass1:
	call	ptr
	ld	de,dummy
	call	set$		; Element speichern
	ret
;
; ASS2
; EIN	Register HL haelt Zeiger
; Fuehrt aus:
;	DATA(HL) := DUMMY
;
ass2:
	call	ptr
	ex	de,hl
	ld	hl,dummy
	jr	set$		; Element holen
;
; ASS3
; EIN	Register HL haelt Zeiger
; Fuehrt aus:
;	DATA(HL+1) := DATA(HL)
;
ass3:
	call	consecutive	; Addressen holen
	ex	de,hl
	jr	set$		; Umkopieren
;
; ASS4
; EIN	Register HL haelt Zeiger 1
; 	Register DEhaelt Zeiger 2
; Fuehrt aus:
;	DATA(HL) := DATA(DE)
;
ass4:
	call	ptr		; Adresse 1 holen
	push	hl
	ex	de,hl
	call	ptr		; .. und Adresse 2
	pop	de
;
; Ein Element umkopieren
; EIN	Register HL haelt Quelladressse
;	Register DE haelt Zieladressse
;
set$:
	ld	bc,(max)
	ldir			; .. umkopieren
	ret
;
; Adressen zweier aufeinanderfolgender Elemente bestimmen
; EIN	Register HL haelt Zeiger
; AUS	Register HL haelt DATA(HL+1)
; 	Register DE haelt DATA(HL)
;
consecutive:
	call	ptr		; Basisadresse laden
	ex	de,hl
	ld	hl,(max)
	add	hl,de		; .. zweite Adresse berechnen
	ret
;
; Adresse aus Zeiger berechnen
; EIN	Register HL haelt Zeiger
; AUS	Register HL haelt Adresse
;
ptr:
	push	de
	dec	hl		; Fixieren fuer Index 0
	ld	de,(max)
	call	multip		; Relativen Zeiger berechnen
	ld	de,($memry)
	add	hl,de		; .. Adresse bestimmen
	pop	de
	ret
;
; Schnittstelle zu den Sortierroutinen
;
sort::
	call	FindTyp		; .. Type finden
	ld	(SortPC+1),de	; .. ablegen
	call	begtim		; Startzeit einfrieren
SortPC:
	call	$-$		; .. sortieren
	call	endtim		; Endzeit einfrieren
	ret
;
; Speicher der Start- und Endzeit
;
begtim:
	call	time
	ld	($beg),hl	; Start speichern
	ret
endtim:
	call	time
	ld	($end),hl	; Ende speichern
	ret
;
; Aktuelle Zeit MM:SS als Ganzzahl holen
; AUS	HL haelt Sekunden als Ganzzahl
;
time:
	ld	c,.gettod
	ld	de,tod
	call	bdos		; Zeit holen
	push	af		; Sekunden retten
	ld	a,(tod+3)	; Minuten holen
	call	BCD2bin
	ld	hl,60
	call	multip		; MM ==>> SS
	pop	af
	call	BCD2bin
	add	hl,de
	ret
;
; BCD nach Ganzzahl wandeln
; EIN	Accu haelt BCD
; AUS	Register DE haelt Ganzzahl
;
BCD2bin:
	ld	d,a
	and	0f0h		; MSD maskieren
	rrca
	rrca
	rrca
	ld	e,a
	add	a,a
	add	a,a
	add	a,e
	ld	e,a
	ld	a,d
	and	00fh		; LSD ebenfalls
	add	a,e
	ld	e,a
	ld	d,0
	ret
;
; Ausgabe der benoetigten Sortierzeit
;
tell$time:
	ld	de,$time1
	call	string
	ld	hl,($end)
	ld	de,($beg)
	or	a
	sbc	hl,de		; Sekunden laden
	push	hl
	call	pr.int
	ld	de,$time2
	call	string
	ld	hl,(curline)
	push	hl
	call	pr.int		; Anzahl Zeilen ausgeben
	ld	de,$time3
	call	string
	ld	hl,(max)
	call	pr.int		; Laenge des Elementes ausgeben
	ld	de,$time4
	call	string
	pop	hl
	pop	de
	call	pr.real
	ld	de,$time5
	call	string
	ret
;
; Ganzzahl ausgeben
; EIN	Register HL haelt Ganzzahl
;
pr.int:
	ld	de,dma
	ld	b,eot
	call	decout		; .. in ASCII wandeln
	ld	de,dma
	call	string
	ret
;
; Ausgabe Zeilen pro Sekunde
; EIN	Register HL haelt Zeilen
;	Register DE haelt Sekunden
;
pr.real:
	ld	a,e
	or	d		; Test ob NULL
	jr	nz,no.null
	ld	de,1		; Minimum (1) setzen
no.null:
	push	de
	ld	de,dma
	call	c16fl		; Umwandeln in Fliesskommazahl
	pop	hl
	ld	de,dma+4
	call	c16fl
	ld	bc,dma
	ld	de,dma+4
	ld	hl,dma
	call	fldiv
	ld	hl,dma
	ld	de,dma+4
	ld	b,eot
	ld	c,8
	ld	a,2
	call	flform
	ld	de,dma+4
	call	skpblk
	call	string
	ret
;
; Sortierungstyp finden
; AUS	Register DE haelt Adresse
;
FindTyp:
	ld	hl,$SORTTYP	; Tabelle setzen
	ld	b,0
nxt.typ:
	ld	c,.fname
	push	bc
	push	hl
	ld	de,@sort
	call	comp3		; .. Typ suchen
	jr	z,got.sort	; .. ok
	pop	hl
	ld	bc,.fname
	add	hl,bc		; Naechster Eintrag
	pop	bc
	inc	b
	inc	b
	ld	a,(hl)		; Test Ende
	or	a
	jr	nz,nxt.typ	; .. weiter
	ld	de,$ILL.TYP	; .. sonst Fehler
	jp	c.err
got.sort:
	pop	hl
	pop	bc
	ld	c,b
	ld	b,0
	ld	hl,SortTab
	add	hl,bc
	ld	e,(hl)		; Adresse aus Tabelle holen
	inc	hl
	ld	d,(hl)
	ret

	dseg

SortTab:
	dw	shake,quick,linear,heap,bubble,binary
$SORTTYP:
	db	'SHAKE   '
	db	'QUICK   '
	db	'LINEAR  '
	db	'HEAP    '
	db	'BUBBLE  '
	db	'BINARY  '
	db	null
$ILL.TYP:
	db	'Sortierung nicht implementiert',eot
$time1:
	db	bell,cr,lf,'Sortierung benoetigte ',eot
$time2:
	db	' Sekunden CPU-Zeit fuer ',eot
$time3:
	db	' Zeilen mit ',eot
$time4:
	db	' Zeichen pro Element',cr,lf,'(',eot
$time5:
	db	' Zeilen/Sekunde)',cr,lf,eot
@sort:
	db	'12345678'
$ERR:
	db	bell,'SORT : ',eot
$filerr:
	db	'Kann Datei nicht finden',eot
$invalid:
	db	'Kein ASCII-Zeichen gefundeb',eot
$nl:
	db	'Ungueltiges Zeilenende',eot
$par:
	db	'Ungueltiger Parameter',eot
$ill:
	db	'Ungueltiger Dateityp',eot
$ovl:
	db	'Datei ist zu gross fuer den Speicher',eot
$create:
	db	'Kann Soertierdatei nicht anlegen',eot
$fileERR:
	db	'Fehler beim Schreiben der Sortierdatei',eot
$read:
	db	'Bestimmung der Laengen ..',cr,lf,eot
$reread:
	db	' Einlesen der Elemente ..',cr,lf,eot
$sort:
	db	'Sortieren der Elemente ..',cr,lf,eot
$wrt:
	db	'Schreiben der Elemente ..',cr,lf,eot
$rdy:
	db	'                Fertig ..',cr,lf,eot
$help:
	db	lf,'Das CP/M PLUS SORT Testprogramm',cr,lf,lf
	db	'Sortiert Textdateien, die nur CR und LF '
	db	'als Kontrollzeichen beinhalten duerfen',cr,lf,lf
	db	'Programm aufrufen mit',cr,lf,lf
	db	tab,tab,'SORT DateiName.ext Typ {[P,L]}'
	db	cr,lf,lf
	db	'Mit:',cr,lf
	db	tab,'DateiName',tab,'Der Name der zu sortierenden Datei'
	db	cr,lf
	db	tab,'ext',tab,tab,'Die Extension dieser Datei'
	db	cr,lf
	db	tab,tab,tab,'(Die neue Datei bekommt die Extension SRT)'
	db	cr,lf
	db	tab,'Typ',tab,tab,'Schluesselwort fuer '
	db	'die Art der Sortierung',cr,lf,lf
	db	tab,'P',tab,tab,'Ist die Spalte, wo die Sortierung beginnt'
	db	cr,lf
	db	tab,tab,tab,'(* bedeutet Spalte 1)',cr,lf
	db	tab,'L',tab,tab,'Ist die Laenge der Zeichenkette, '
	db	'nach der sortiert wird',cr,lf
	db	tab,tab,tab,'(* bedeutet komplette Kette)'
	db	cr,lf,lf
	db	'Sortierung ohne Optionen ist gleich [*,*]'
	db	cr,lf,lf
	db	'Aktuell implementierte Arten:',cr,lf,lf
	db	tab,'LINEAR',tab,'BINARY',cr,lf
	db	tab,'BUBBLE',tab,'SHAKE',cr,lf
	db	tab,'HEAP',tab,'QUICK',cr,lf
	db	cr,lf,eot

wrt$nl:	db	cr,lf,null

SORTfcb:db	0,'12345678SRT'
	ds	24

$memry:
	dw	0
curptr:
	dw	0
p.def:
	db	false
l.def:
	db	false
max:
	dw	0
pos:
	ds	2
length:
	ds	2
curline:
	dw	0
my_line:
	db	132,0
dummy:
	ds	132
.dummy:
	ds	132
tod:
	ds	4
$beg:
	ds	2
$end:
	ds	2

ptr.1:
	ds	2
ptr.2:
	ds	2
ptr.3:
	ds	2
ptr.4:
	ds	2
ptr.5:
	ds	2

	ds	2*32
mystack:
	end