aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Another update from ingydotnet^djgoku

Browse source
This commit is contained in:
Ingy döt Net 2015-11-18 06:14:39 +00:00
parent 91df62d461
commit 948b86eafa
7604 changed files with 108452 additions and 22726 deletions
Download patch file Download diff file Expand all files Collapse all files

365
Task/Natural-sorting/Fortran/natural-sorting-1.f Normal file
View file

@ -0,0 +1,365 @@
MODULE STASHTEXTS !Using COMMON is rather more tedious.
INTEGER MSG,KBD !I/O unit numbers.
DATA MSG,KBD/6,5/ !Output, input.
INTEGER LSTASH,NSTASH,MSTASH !Prepare a common text stash.
PARAMETER (LSTASH = 2468, MSTASH = 234) !LSTASH characters for MSTASH texts.
INTEGER ISTASH(MSTASH + 1) !Index to start positions.
CHARACTER*(LSTASH) STASH !One pool.
DATA NSTASH,ISTASH(1)/0,1/ !Which is empty.
CONTAINS
SUBROUTINE CROAK(GASP) !A dying remark.
CHARACTER*(*) GASP !The last words.
WRITE (MSG,*) "Oh dear." !Shock.
WRITE (MSG,*) GASP !Aargh!
STOP "How sad." !Farewell, cruel world.
END SUBROUTINE CROAK !Farewell...
SUBROUTINE UPCASE(TEXT) !In the absence of an intrinsic...
Converts any lower case letters in TEXT to upper case...
Concocted yet again by R.N.McLean (whom God preserve) December MM.
Converting from a DO loop evades having both an iteration counter to decrement and an index variable to adjust.
CHARACTER*(*) TEXT !The stuff to be modified.
c CHARACTER*26 LOWER,UPPER !Tables. a-z may not be contiguous codes.
c PARAMETER (LOWER = "abcdefghijklmnopqrstuvwxyz")
c PARAMETER (UPPER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CAREFUL!! The below relies on a-z and A-Z being contiguous, as is NOT the case with EBCDIC.
INTEGER I,L,IT !Fingers.
L = LEN(TEXT) !Get a local value, in case LEN engages in oddities.
I = L !Start at the end and work back..
1 IF (I.LE.0) RETURN !Are we there yet? Comparison against zero should not require a subtraction.
c IT = INDEX(LOWER,TEXT(I:I)) !Well?
c IF (IT .GT. 0) TEXT(I:I) = UPPER(IT:IT) !One to convert?
IT = ICHAR(TEXT(I:I)) - ICHAR("a") !More symbols precede "a" than "A".
IF (IT.GE.0 .AND. IT.LE.25) TEXT(I:I) = CHAR(IT + ICHAR("A")) !In a-z? Convert!
I = I - 1 !Back one.
GO TO 1 !Inspect..
END SUBROUTINE UPCASE !Easy.
SUBROUTINE SHOWSTASH(BLAH,I) !One might be wondering.
CHARACTER*(*) BLAH !An annotation.
INTEGER I !The desired stashed text.
IF (I.LE.0 .OR. I.GT.NSTASH) THEN !Paranoia rules.
WRITE (MSG,1) BLAH,I !And is not always paranoid.
1 FORMAT (A,': Text(',I0,') is not in the stash!') !Hopefully, helpful.
ELSE !But surely I will only be asked for what I have.
WRITE (MSG,2) BLAH,I,STASH(ISTASH(I):ISTASH(I + 1) - 1) !Whee!
2 FORMAT (A,': Text(',I0,')=>',A,'<') !Hopefully, informative.
END IF !So, it is shown.
END SUBROUTINE SHOWSTASH !Ah, debugging.
INTEGER FUNCTION STASHIN(L2) !Assimilate the text ending at L2.
Careful: furrytran regards "blah" and "blah " as equal, so, compare lengths first.
INTEGER L2 !The text to add is at ISTASH(NSTASH + 1):L2.
INTEGER I,L1 !Assistants.
L1 = ISTASH(NSTASH + 1)!Where the scratchpad starts.
L = L2 - L1 + 1 !The length of the text.
Check to see if I already have stashed this exact text.
DO I = 1,NSTASH !Search my existing texts.
IF (L.EQ.ISTASH(I + 1) - ISTASH(I)) THEN !Matching lengths?
IF (STASH(L1:L2) !Yes. Does the scratchpad
1 .EQ.STASH(ISTASH(I):ISTASH(I + 1) - 1)) THEN !Match the stashed text?
STASHIN = I !Yes! I already have this exact text.
RETURN !And there is no need to duplicate it.
END IF !So much for matching text, furrytran style.
END IF !This time, trailing space differences will count.
END DO !On to the next stashed text.
Can't find it. Assimilate the scratchpad. No text is moved, just extend the fingers.
IF (NSTASH.GE.MSTASH) CALL CROAK("The text pool is crowded!") !Alas.
IF (L2.GT.LSTASH) CALL CROAK("Overtexted!") !Alack.
NSTASH = NSTASH + 1 !Count in another entry.
ISTASH(NSTASH + 1) = L2 + 1 !The new "first available" position.
STASHIN = NSTASH !Fingered for the caller.
END FUNCTION STASHIN !Rather than assimilating a supplied text.
END MODULE STASHTEXTS !Others can extract text as they wish.
MODULE BADCHARACTER !Some characters are not for glyphs but for action.
CHARACTER*1 BS,HT,LF,VT,FF,CR !Nicknames for a bunch of troublemakers.
CHARACTER*6 BADC,GOODC !I want a system.
INTEGER*1 IBADC(6) !Initialisation syntax is restricive.
PARAMETER (GOODC="btnvfr") !Mnemonics.
EQUIVALENCE (BADC(1:1),BS),(BADC(2:2),HT),(BADC(3:3),LF),!Match the names
1 (BADC(4:4),VT),(BADC(5:5),FF),(BADC(6:6),CR), !To their character.
2 (IBADC,BADC) !Alas, a PARAMETER style is rejected.
DATA IBADC/8,9,10,11,12,13/ !ASCII encodements.
PRIVATE IBADC !Keep this quiet.
END MODULE BADCHARACTER !They can disrupt layout.
MODULE COMPOUND !Stores entries, each of multiple parts, each part a text and a number.
USE STASHTEXTS !Gain access to the text repository.
INTEGER LENTRY,NENTRY,MENTRY !Entry counting.
PARAMETER (MENTRY = 28) !Should be enough for the test runs.
INTEGER TENTRY(MENTRY) !Each entry has a source text somewhere in STASH.
INTEGER IENTRY(MENTRY + 1) !This fingers its first part in PARTT and PARTI.
INTEGER MPART,NPART !Now for the pool of parts.
PARAMETER (MPART = 120) !Should suffice.
INTEGER PARTT(MPART) !A part's text number in STASH.
INTEGER PARTI(MPART) !A part's number, itself.
DATA NENTRY,NPART,IENTRY(1)/0,0,1/ !There are no entries, with no parts either.
CONTAINS !The fun begins.
INTEGER FUNCTION ADDENTRY(X) !Create an entry holding X.
Chops X into many parts, alternating <text><integer>,<text><integer>,...
Converts the pieces' texts to upper case, as they will be used as a sort key later.
CHARACTER*(*) X !The text.
INTEGER BORED,GRIST,NUMERIC !Might as well supply some mnemonics.
PARAMETER (BORED = 0, GRIST = 1, NUMERIC = 2) !For nearly arbitrary integers.
INTEGER I,STATE,D !For traipsing through the text.
INTEGER L1,L2 !Bounds of the scratchpad in STASH.
CHARACTER*1 C !Save on some typing.
Create a new entry. First, save its source text exactly as supplied.
IF (NENTRY.GE.MENTRY) CALL CROAK("Too many entries!") !Perhaps I can't.
NENTRY = NENTRY + 1 !Another entry.
L2 = ISTASH(NSTASH + 1) - 1 !Find my scratchpad.
STASH(L2 + 1:L2 + LEN(X)) = X !Place the text as it stands.
TENTRY(NENTRY) = STASHIN(L2 + LEN(X)) !Find a finger to it in my text stash.
CALL SHOWSTASH("Entering",TENTRY(NENTRY)) !Ah, debugging.
ADDENTRY = NENTRY !I shall return this.
Contemplate the text of the entry. Leading spaces, multiple spaces, numeric portions...
STATE = BORED !As if in leading space stuff.
L2 = ISTASH(NSTASH + 1) - 1 !Syncopation for text piece placement.
N = 0 !A number may be encountered.
DO I = 1,LEN(X) !Step through the text.
C = X(I:I) !Grab a character.
IF (C.LE." ") THEN !A space, or somesuch.
SELECT CASE(STATE) !What were we doing?
CASE(BORED) !Ignoring spaces.
!Do nothing with this one too.
CASE(GRIST) !We were in stuff.
CALL ONESPACE !So accept one space only.
CASE(NUMERIC) !We were in a number.
CALL ADDPART !So, the number has been ended.
STATE = BORED !But the space wot did it is ignored.
CASE DEFAULT !This should never happen.
CALL CROAK("Confused state!") !So this shouldn't.
END SELECT !So much for encountering spaceish stuff.
ELSE IF ("0".LE.C .AND. C.LE."9") THEN !A digit?
D = ICHAR(C) - ICHAR("0") !Yes. Convert to a numerical digit.
N = N*10 + D !Assimilate into a proper number.
STATE = NUMERIC !Perhaps more digits follow.
ELSE !All other characters are accepted as they stand.
IF (STATE.EQ.NUMERIC) CALL ADDPART !A number has just ended.
L2 = L2 + 1 !Starting a new pair's text.
STASH(L2:L2) = C !With this.
STATE = GRIST !And anticipating more to come.
END IF !Types are: spaceish, grist, digits.
END DO !On to the next character.
CALL ADDPART !Ended by the end-of-text.
IENTRY(NENTRY + 1) = NPART + 1 !Thus be able to find an entry's last part.
CONTAINS !Odd assistants.
SUBROUTINE ONESPACE !Places a space, then declares BORED.
L2 = L2 + 1 !Advance one.
STASH(L2:L2) = " " !An actual blank.
STATE = BORED !Any subsequent spaces are to be ignored.
END SUBROUTINE ONESPACE!Skipping them.
SUBROUTINE ADDPART !Augment the paired PARTT and PARTI.
IF (NPART.GE.MPART) CALL CROAK("Too many parts!") !If space remains.
NPART = NPART + 1 !So, another part.
IF (STASH(L2:L2).EQ." ") L2 = L2 - 1 !A trailing space trimmed. BORED means at most only one.
L1 = ISTASH(NSTASH + 1) !My scratchpad starts after the last stashed text.
CALL UPCASE(STASH(L1:L2)) !Simplify the text to be a sort key part.
IF (IENTRY(NENTRY).EQ.NPART) CALL LIBRARIAN !The first part of an entry?
PARTT(NPART) = STASHIN(L2) !Finger the text part.
PARTI(NPART) = N !Save the numerical value.
L2 = ISTASH(NSTASH + 1) - 1 !The text may not have been a newcomer.
N = 0 !Ready for another number.
END SUBROUTINE ADDPART !Always paired, even if no number was found.
SUBROUTINE LIBRARIAN !Adjusts names starting "The ..." or "An ..." or "A ...", library style.
CHARACTER*4 ARTICLE(3) !By chance, three, by happy chance, lengths 1, 2, 3!
PARAMETER (ARTICLE = (/"A","AN","THE"/)) !These each have trailing space.
INTEGER I !A stepper.
DO I = 1,3 !So step through the known articles.
IF (L1 + I.GT.L2) RETURN !Insufficient text? Give up.
IF (STASH(L1:L1 + I).EQ.ARTICLE(I)(1:I + 1)) THEN !Starts with this one?
STASH(L1:L2 - I - 1) = STASH(L1 + I + 1:L2) !Yes! Shift the rest back over it.
STASH(L2 - I:L2 + 1) = ", "//ARTICLE(I)(1:I) !Place the article at the end.
L2 = L2 + 1 !One more, for the comma.
RETURN !Done!
END IF !But if that article didn't match,
END DO !Try the next.
END SUBROUTINE LIBRARIAN !Ah, catalogue order. Blah, The.
END FUNCTION ADDENTRY !That was fun!
SUBROUTINE SHOWENTRY(BLAH,E) !Ah, debugging.
CHARACTER*(*) BLAH !With distinguishing mark.
INTEGER E,P !Entry and part fingering.
INTEGER L1,L2 !Fingers.
L1 = ISTASH(TENTRY(E)) !The source text is stashed as text #TENTRY(E).
L2 = ISTASH(TENTRY(E) + 1) - 1 !ISTASH(i) is where in STASH text #i starts.
WRITE (MSG,1) BLAH,E,IENTRY(E),IENTRY(E + 1) - 1,STASH(L1:L2)
1 FORMAT (/,A," Entry(",I0,")=Pt ",I0," to ",I0,", text >",A,"<")
DO P = IENTRY(E),IENTRY(E + 1) - 1 !Step through the part list.
L1 = ISTASH(PARTT(P)) !Find the text of the part.
L2 = ISTASH(PARTT(P) + 1) - 1 !Saved in STASH.
WRITE (MSG,2) P,PARTT(P),PARTI(P),STASH(L1:L2) !The text is of variable length,
2 FORMAT ("Part(",I0,") = text#",I0,", N = ",I0," >",A,"<") !So present it *after* the number.
END DO !On to the next part.
END SUBROUTINE SHOWENTRY !Shows entry = <text><number>, <text><number>, ...
INTEGER FUNCTION ENTRYORDER(E1,E2) !Report on the order of entries E1 and E2.
Chug through the parts list of the two entries, for each part comparing the text, then the number.
INTEGER E1,E2 !Finger entries via TENTRY(i) and IENTRY(i)...
INTEGER T1,T2 !Fingers texts in STASH.
INTEGER I1,N1,I2,N2 !Fingers and counts.
INTEGER I,D !A stepper and a difference.
c CALL SHOWENTRY("E1",E1)
c CALL SHOWENTRY("E2",E2)
P1 = IENTRY(E1) !Finger the first parts
P2 = IENTRY(E2) !Of the two entries.
Compare the text part of the two parts.
10 T1 = PARTT(P1) !So, what is the number of the text,
T2 = PARTT(P2) !Safely stored in STASH.
IF (T1.NE.T2) THEN !Inspect text only if the text parts differ.
I1 = ISTASH(T1) !Where its text is stashed.
N1 = ISTASH(T1 + 1) - I1 !Thus the length of that text.
I2 = ISTASH(T2) !First character of the other text.
N2 = ISTASH(T2 + 1) - I2 !Thus its length.
DO I = 1,MIN(N1,N2) !Step along both texts while they have characters to match.
D = ICHAR(STASH(I2:I2)) - ICHAR(STASH(I1:I1)) !The difference.
IF (D.NE.0) GO TO 666 !Is there a difference?
I1 = I1 + 1 !No.
I2 = I2 + 1 !Advance to the next character for both.
END DO !And try again.
Can't compare character pairs beyond the shorter of the two texts.
D = N2 - N1 !Very well, which text is the shorter?
IF (D.NE.0) GO TO 666 !No difference in length?
END IF !So much for the text comparison.
Compare the numeric part.
D = PARTI(P2) - PARTI(P1) !Righto, compare the numeric side.
IF (D.NE.0) GO TO 666 !A difference here?
Can't find any difference between those two parts.
P1 = P1 + 1 !Move on to the next part.
P2 = P2 + 1 !For both entries.
N1 = IENTRY(E1 + 1) - P1 !Knowing where the next entry's parts start
N2 = IENTRY(E2 + 1) - P2 !Means knowing where an entry's parts end.
IF (N1.GT.0 .AND. N2.GT.0) GO TO 10 !At least one for both, so compare the next pair.
D = N2 - N1 !Thus, the shorter precedes the longer.
Conclusion.
666 ENTRYORDER = D !Zero sez "equal".
END FUNCTION ENTRYORDER !That was a struggle.
SUBROUTINE ORDERENTRY(LIST,N)
Crank up a Comb sort of the entries fingered by LIST. Working backwards, just for fun.
Caution: the H*10/13 means that H ought not be INTEGER*2. Otherwise, use H/1.3.
INTEGER LIST(*) !This is an index to the items being compared.
INTEGER T !In the absence of a SWAP(a,b). Same type as LIST.
INTEGER N !The number of entries.
INTEGER I,H !Tools. H ought not be a small integer.
LOGICAL CURSE !Annoyance.
H = N - 1 !Last - First, and not +1.
IF (H.LE.0) RETURN !Ha ha.
1 H = MAX(1,H*10/13) !The special feature.
IF (H.EQ.9 .OR. H.EQ.10) H = 11 !A twiddle.
CURSE = .FALSE. !So far, so good.
DO I = N - H,1,-1 !If H = 1, this is a BubbleSort.
IF (ENTRYORDER(LIST(I),LIST(I + H)).LT.0) THEN !One compare.
T=LIST(I); LIST(I)=LIST(I+H); LIST(I+H)=T !One swap.
CURSE = .TRUE. !One curse.
END IF !One test.
END DO !One loop.
IF (CURSE .OR. H.GT.1) GO TO 1 !Work remains?
END SUBROUTINE ORDERENTRY
CHARACTER*44 FUNCTION ENTRYTEXT(E) !Ad-hoc extraction of an entry's source text.
INTEGER E !The desired entry's number.
INTEGER P !A stage in the dereferencing.
P = TENTRY(E) !Entry E's source text is #P.
ENTRYTEXT = STASH(ISTASH(P):ISTASH(P + 1) - 1) !Stashed here.
END FUNCTION ENTRYTEXT !Fixed size only, with trailing spaces.
CHARACTER*44 FUNCTION ENTRYTEXTCHAR(E) !The same, but with nasty characters defanged.
USE BADCHARACTER !Just so.
INTEGER E !The desired entry's number.
INTEGER P !A stage in the dereferencing.
CHARACTER*44 TEXT !A scratchpad, to avoid confusing the compiler.
INTEGER I,L,H !Fingers.
CHARACTER*1 C !A waystation.
L = 0 !No text has been extracted.
P = TENTRY(E) !Entry E's source text is #P.
DO I = ISTASH(P),ISTASH(P + 1) - 1 !Step along the stash..
C = STASH(I:I) !Grab a character.
H = INDEX(BADC,C) !Scan the shit list.
IF (H.LE.0) THEN !One of the troublemakers?
CALL PUT(C) !No. Just copy it.
ELSE !Otherwise,
CALL PUT("!") !Place a context changer.
CALL PUT(GOODC(H:H)) !Place the corresponding mnemonic.
END IF !So much for that character.
END DO !On to the next.
ENTRYTEXTCHAR = TEXT(1:MIN(L,44)) !Protect against overflow.
CONTAINS !A trivial assistant.
SUBROUTINE PUT(C) !But too messy to have in-line.
CHARACTER*1 C !The character of the moment.
L = L + 1 !Advance to place it.
IF (L.LE.44) TEXT(L:L) = C !If within range.
END SUBROUTINE PUT !Simple enough.
END FUNCTION ENTRYTEXTCHAR !On output, the troublemakers make trouble.
SUBROUTINE ORDERENTRYTEXT(LIST,N)
Crank up a Comb sort of the entries fingered by LIST. Working backwards, just for fun.
Caution: the H*10/13 means that H ought not be INTEGER*2. Otherwise, use H/1.3.
INTEGER LIST(*) !This is an index to the items being compared.
INTEGER T !In the absence of a SWAP(a,b). Same type as LIST.
INTEGER N !The number of entries.
INTEGER I,H !Tools. H ought not be a small integer.
LOGICAL CURSE !Annoyance.
H = N - 1 !Last - First, and not +1.
IF (H.LE.0) RETURN !Ha ha.
1 H = MAX(1,H*10/13) !The special feature.
IF (H.EQ.9 .OR. H.EQ.10) H = 11 !A twiddle.
CURSE = .FALSE. !So far, so good.
DO I = N - H,1,-1 !If H = 1, this is a BubbleSort.
IF (ENTRYTEXT(LIST(I)).GT.ENTRYTEXT(LIST(I+H))) THEN !One compare.
T=LIST(I); LIST(I)=LIST(I+H); LIST(I+H)=T !One swap.
CURSE = .TRUE. !One curse.
END IF !One test.
END DO !One loop.
IF (CURSE .OR. H.GT.1) GO TO 1 !Work remains?
END SUBROUTINE ORDERENTRYTEXT
END MODULE COMPOUND !Accepts, stores, lists and sorts the content.
PROGRAM MR NATURAL !Presents a list in sorted order.
USE COMPOUND !Stores text in a complicated way.
USE BADCHARACTER !Some characters wreck the layout.
INTEGER I,ITEM(30),PLAIN(30) !Two sets of indices.
I = 0 !An array must have equal-length items, so trailing spaces would result.
I=I+1;ITEM(I) = ADDENTRY("ignore leading spaces: 2-2")
I=I+1;ITEM(I) = ADDENTRY(" ignore leading spaces: 2-1")
I=I+1;ITEM(I) = ADDENTRY(" ignore leading spaces: 2+0")
I=I+1;ITEM(I) = ADDENTRY(" ignore leading spaces: 2+1")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2-2")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2-1")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2+0")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2+1")
I=I+1;ITEM(I) = ADDENTRY("Equiv."//" "//"spaces: 3-3")
I=I+1;ITEM(I) = ADDENTRY("Equiv."//CR//"spaces: 3-2") !CR can't appear as itself.
I=I+1;ITEM(I) = ADDENTRY("Equiv."//FF//"spaces: 3-1") !As it is used to mark line endings.
I=I+1;ITEM(I) = ADDENTRY("Equiv."//VT//"spaces: 3+0") !And if typed in an editor,
I=I+1;ITEM(I) = ADDENTRY("Equiv."//LF//"spaces: 3+1") !It is acted upon there and then.
I=I+1;ITEM(I) = ADDENTRY("Equiv."//HT//"spaces: 3+2") !So, name instead of value.
I=I+1;ITEM(I) = ADDENTRY("cASE INDEPENDENT: 3-2")
I=I+1;ITEM(I) = ADDENTRY("caSE INDEPENDENT: 3-1")
I=I+1;ITEM(I) = ADDENTRY("casE INDEPENDENT: 3+0")
I=I+1;ITEM(I) = ADDENTRY("case INDEPENDENT: 3+1")
I=I+1;ITEM(I) = ADDENTRY("foo100bar99baz0.txt")
I=I+1;ITEM(I) = ADDENTRY("foo100bar10baz0.txt")
I=I+1;ITEM(I) = ADDENTRY("foo1000bar99baz10.txt")
I=I+1;ITEM(I) = ADDENTRY("foo1000bar99baz9.txt")
I=I+1;ITEM(I) = ADDENTRY("The Wind in the Willows")
I=I+1;ITEM(I) = ADDENTRY("The 40th step more")
I=I+1;ITEM(I) = ADDENTRY("The 39 steps")
I=I+1;ITEM(I) = ADDENTRY("Wanda")
c I=I+1;ITEM(I) = ADDENTRY("A Dinosaur Grunts: Fortran Emerges")
c I=I+1;ITEM(I) = ADDENTRY("The Joy of Text Twiddling with Fortran")
c I=I+1;ITEM(I) = ADDENTRY("An Aversion to Unused Trailing Spaces")
WRITE (MSG,*) "nEntry=",NENTRY !Reach into the compound storage area.
PLAIN = ITEM !Copy the list of entries.
CALL ORDERENTRY(ITEM,NENTRY) !"Natural" order.
CALL ORDERENTRYTEXT(PLAIN,NENTRY) !Plain text order.
WRITE (MSG,1) "Character","'Natural'" !Provide a heading.
1 FORMAT (2("Entry|Text ",A9," Order",24X)) !Usual trickery.
DO I = 1,NENTRY !Step through the lot.
WRITE (MSG,2) PLAIN(I),ENTRYTEXTCHAR(PLAIN(I)), !Plain order,
1 ITEM(I), ENTRYTEXTCHAR(ITEM(I)) !Followed by natural order.
2 FORMAT (2(I5,"|",A44)) !This follows function ENTRYTEXT.
END DO !On to the next.
END !A handy hint from Mr. Natural: "At home or at work, get the right tool for the job!"

325
Task/Natural-sorting/Fortran/natural-sorting-2.f Normal file
View file

@ -0,0 +1,325 @@
MODULE ASSISTANCE
INTEGER MSG,KBD !I/O unit numbers.
DATA MSG,KBD/6,5/ !Output, input.
CONTAINS
SUBROUTINE CROAK(GASP) !A dying remark.
CHARACTER*(*) GASP !The last words.
WRITE (MSG,*) "Oh dear." !Shock.
WRITE (MSG,*) GASP !Aargh!
STOP "How sad." !Farewell, cruel world.
END SUBROUTINE CROAK !Farewell...
SUBROUTINE UPCASE(TEXT) !In the absence of an intrinsic...
Converts any lower case letters in TEXT to upper case...
Concocted yet again by R.N.McLean (whom God preserve) December MM.
Converting from a DO loop evades having both an iteration counter to decrement and an index variable to adjust.
CHARACTER*(*) TEXT !The stuff to be modified.
c CHARACTER*26 LOWER,UPPER !Tables. a-z may not be contiguous codes.
c PARAMETER (LOWER = "abcdefghijklmnopqrstuvwxyz")
c PARAMETER (UPPER = "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
CAREFUL!! The below relies on a-z and A-Z being contiguous, as is NOT the case with EBCDIC.
INTEGER I,L,IT !Fingers.
L = LEN(TEXT) !Get a local value, in case LEN engages in oddities.
I = L !Start at the end and work back..
1 IF (I.LE.0) RETURN !Are we there yet? Comparison against zero should not require a subtraction.
c IT = INDEX(LOWER,TEXT(I:I)) !Well?
c IF (IT .GT. 0) TEXT(I:I) = UPPER(IT:IT) !One to convert?
IT = ICHAR(TEXT(I:I)) - ICHAR("a") !More symbols precede "a" than "A".
IF (IT.GE.0 .AND. IT.LE.25) TEXT(I:I) = CHAR(IT + ICHAR("A")) !In a-z? Convert!
I = I - 1 !Back one.
GO TO 1 !Inspect..
END SUBROUTINE UPCASE !Easy.
INTEGER FUNCTION LSTNB(TEXT) !Sigh. Last Not Blank.
Concocted yet again by R.N.McLean (whom God preserve) December MM.
Code checking reveals that the Compaq compiler generates a copy of the string and then finds the length of that when using the latter-day intrinsic LEN_TRIM. Madness!
Can't DO WHILE (L.GT.0 .AND. TEXT(L:L).LE.' ') !Control chars. regarded as spaces.
Curse the morons who think it good that the compiler MIGHT evaluate logical expressions fully.
Crude GO TO rather than a DO-loop, because compilers use a loop counter as well as updating the index variable.
Comparison runs of GNASH showed a saving of ~3% in its mass-data reading through the avoidance of DO in LSTNB alone.
Crappy code for character comparison of varying lengths is avoided by using ICHAR which is for single characters only.
Checking the indexing of CHARACTER variables for bounds evoked astounding stupidities, such as calculating the length of TEXT(L:L) by subtracting L from L!
Comparison runs of GNASH showed a saving of ~25-30% in its mass data scanning for this, involving all its two-dozen or so single-character comparisons, not just in LSTNB.
CHARACTER*(*),INTENT(IN):: TEXT !The bumf. If there must be copy-in, at least there need not be copy back.
INTEGER L !The length of the bumf.
L = LEN(TEXT) !So, what is it?
1 IF (L.LE.0) GO TO 2 !Are we there yet?
IF (ICHAR(TEXT(L:L)).GT.ICHAR(" ")) GO TO 2 !Control chars are regarded as spaces also.
L = L - 1 !Step back one.
GO TO 1 !And try again.
2 LSTNB = L !The last non-blank, possibly zero.
RETURN !Unsafe to use LSTNB as a variable.
END FUNCTION LSTNB !Compilers can bungle it.
END MODULE ASSISTANCE
MODULE BADCHARACTER !Some characters are not for glyphs but for action.
CHARACTER*1 BS,HT,LF,VT,FF,CR !Nicknames for a bunch of troublemakers.
CHARACTER*6 BADC,GOODC !I want a system.
INTEGER*1 IBADC(6) !Initialisation syntax is restricive.
PARAMETER (GOODC="btnvfr") !Mnemonics.
EQUIVALENCE (BADC(1:1),BS),(BADC(2:2),HT),(BADC(3:3),LF),!Match the names
1 (BADC(4:4),VT),(BADC(5:5),FF),(BADC(6:6),CR), !To their character.
2 (IBADC,BADC) !Alas, a PARAMETER style is rejected.
DATA IBADC/8,9,10,11,12,13/ !ASCII encodements.
PRIVATE IBADC !Keep this quiet.
CONTAINS
CHARACTER*44 FUNCTION DEFANG(THIS) !Ad-hoc text conversion with nasty characters defanged.
CHARACTER*(*) THIS !The text.
CHARACTER*44 TEXT !A scratchpad, to avoid confusing the compiler.
INTEGER I,L,H !Fingers.
CHARACTER*1 C !A waystation.
L = 0 !No text has been extracted.
DO I = 1,LEN(THIS) !Step along the stash..
C = THIS(I:I) !Grab a character.
H = INDEX(BADC,C) !Scan the shit list.
IF (H.LE.0) THEN !One of the troublemakers?
CALL PUT(C) !No. Just copy it.
ELSE !Otherwise,
CALL PUT("!") !Place a context changer.
CALL PUT(GOODC(H:H)) !Place the corresponding mnemonic.
END IF !So much for that character.
END DO !On to the next.
DEFANG = TEXT(1:MIN(L,44)) !Protect against overflow.
CONTAINS !A trivial assistant.
SUBROUTINE PUT(C) !But too messy to have in-line.
CHARACTER*1 C !The character of the moment.
L = L + 1 !Advance to place it.
IF (L.LE.44) TEXT(L:L) = C !If within range.
END SUBROUTINE PUT !Simple enough.
END FUNCTION DEFANG !On output, the troublemakers make trouble.
END MODULE BADCHARACTER !They can disrupt layout.
MODULE COMPOUND !Stuff to store the text entries, and to sort lists.
USE ASSISTANCE
INTEGER LENTRY,NENTRY,MENTRY !Size information.
PARAMETER (LENTRY = 66, MENTRY = 666) !Should suffice.
INTEGER ENTRYLENGTH(MENTRY) !Lengths for the entries.
CHARACTER*(LENTRY) ENTRYTEXT(MENTRY) !Their texts.
CHARACTER*(LENTRY) ENTRYKEY(MENTRY) !Comparison keys.
CONTAINS !The details.
INTEGER FUNCTION ADDENTRY(X) !Create an entry holding X.
CHARACTER*(*) X !The text to be stashed.
INTEGER L !It may have trailing space stuff.
L = LSTNB(X) !Thus, LEN(X) won't do.
IF (L.GT.LENTRY) CALL CROAK("Over-long text!") !Even though any trailing spaces have been lost.
IF (NENTRY.GE.MENTRY) CALL CROAK("Too many entries!") !Perhaps I can't.
NENTRY = NENTRY + 1 !Righto, another one.
ENTRYTEXT(NENTRY)(1:L) = X(1:L)!Place. Trailing spaces will not be supplied.
ENTRYLENGTH(NENTRY) = L !But I won't be looking where they won't be.
ADDENTRY = NENTRY !The caller needn't keep count.
END FUNCTION ADDENTRY !That was simple.
INTEGER FUNCTION TEXTORDER(E1,E2) !Compare the texts as they stand.
INTEGER E1,E2 !Finger the entries holding the texts.
IF (ENTRYTEXT(E1)(1:ENTRYLENGTH(E1)) !If the text of entry E1
1 .LT.ENTRYTEXT(E2)(1:ENTRYLENGTH(E2))) THEN !Precedes that of E2,
TEXTORDER = +1 !Then the order is good.
ELSE IF (ENTRYTEXT(E1)(1:ENTRYLENGTH(E1)) !ENTRYLENGTH means no trailing spaces.
1 .GT.ENTRYTEXT(E2)(1:ENTRYLENGTH(E2))) THEN !Accordingly, no "x" = "x " accommodation.
TEXTORDER = -1 !So, reversed order.
ELSE !Otherwise,
TEXTORDER = 0 !They're equal.
END IF !So, decided.
END FUNCTION TEXTORDER !Thus use the character collation sequence.
INTEGER FUNCTION NATURALORDER(E1,E2) !Compares the texts in "natural" order.
INTEGER E1,E2 !Pity this couldn't be an array of two values.
CHARACTER*4 ARTICLE(3) !By chance, three, by happy chance, lengths 1, 2, 3!
PARAMETER (ARTICLE = (/"A","AN","THE"/)) !These each have trailing space.
INTEGER DONE,BORED,GRIST,NUMERIC !Might as well supply some mnemonics.
PARAMETER (DONE=-1,BORED=0,GRIST=1,NUMERIC=2) !For nearly arbitrary integers.
INTEGER WOT(2) !Collect the two entry numbers.
INTEGER L(2),LST(2) !Scan text with finger L, ending with LST.
INTEGER N !Counter for comparisons.
INTEGER DCOUNT(2) !Counts the number of digits for L(is) onwards.
INTEGER STATE(2) !The scans vary in mood.
INTEGER TAIL(2) !The LIBRARIAN may discover an ARTICLE and put it in the TAIL.
INTEGER D !A difference.
CHARACTER*1 C(2) !Character pairs ascertained one-by-one by ANOTHER.
WOT(1) = E1 !Alright,
WOT(2) = E2 !Into an array to play.
L = 0 !Syncopation to start the scan.
LST = ENTRYLENGTH(WOT) !End markers.
STATE = BORED !So far, and no matter what the librarian discovers.
DCOUNT = 0 !Nor have any digits been counted.
CALL LIBRARIAN !Assess the start of the texts.
N = 0 !No comparisons so far.
Chug along the texts, character by character.
10 CALL ANOTHER !Grab one from each text.
N = N + 1 !Count another compare.
ENTRYKEY(WOT)(N:N) = C !Place the characters being compared.
D = ICHAR(C(2)) - ICHAR(C(1)) !Their difference.
IF (D.NE.0) GO TO 666 !A decision yet?
L = L + 1 !No. Advance both fingers.
IF (ANY(STATE.NE.DONE)) GO TO 10 !And try again.
666 NATURALORDER = D !The decision.
RETURN !Despite the lack of an END, this is the end of the function.
CONTAINS !Which however contains some assistants, defined after use.
SUBROUTINE CRUSH(C) !Reduces annoying variation.
CHARACTER*1 C !The victim.
IF (C.LE." ") THEN !Spaceish?
C = " " !Yes. Standardise.
ELSE !For all others,
CALL UPCASE(C) !Simplify.
END IF !Righto, ready to compare.
END SUBROUTINE CRUSH !This should do the deed in place.
SUBROUTINE ANOTHER !The entry's text may be followed by an article in the tail.
Claws along the text strings, looking for the next character pair to report for matching.
INTEGER IS !Steps through the two texts.
INTEGER L2 !A second finger, for probing ahead and the TAIL.
CHARACTER*1 D !Potentially a digit character.
EE:DO IS = 1,2 !Dealing with both texts in the same way.
10 L2 = L(IS) - LST(IS) !Compare the finger to the end-of-text.
IF (L2.GT.0) THEN !Perhaps we have reached the tail.
IF (TAIL(IS).GT.0 .AND. L2.LE.TAIL(IS)) THEN !Yes. What about the possible tail?
C(IS) = ARTICLE(TAIL(IS))(L2:L2) !Still wagging.
ELSE !But if no tail (or the tail is exhausted)
C(IS) = CHAR(0) !Empty space.
STATE(IS) = DONE !Declare this.
END IF !So much for the librarian's tail.
CYCLE EE !On to the next text.
END IF !But if we have text yet to scan,
C(IS) = ENTRYTEXT(WOT(IS))(L(IS):L(IS)) !Grab the character.
CALL CRUSH(C(IS)) !Simplify.
IF (C(IS).EQ." ") THEN !So, what have we received?
IF (STATE(IS).EQ.BORED) THEN !A space. Are we ignoring them?
L(IS) = L(IS) + 1 !Yes. Advance in hope.
GO TO 10 !And try again.
END IF !So much for another space.
STATE(IS) = BORED !If we weren't in spaces, we are now.
ELSE IF (C(IS).GE."0" .AND. C(IS).LE."9") THEN !A digit?
STATE(IS) = NUMERIC !Double trouble might ensue.
ELSE !For all other characters,
STATE(IS) = GRIST !We have grist.
END IF !So much for the character.
END DO EE !On to the next text.
Comparing digit sequences is to be done as numbers. "007" vs "70" is to become vs. "070" by length matching.
IF (ALL(STATE.EQ.NUMERIC)) THEN !If we're comparing a digit to a digit,
IF (ALL(DCOUNT.EQ.0)) THEN !I want to align the comparison from the right.
DD:DO IS = 1,2 !So I need to determine how many digits follow in both.
20 DCOUNT(IS) = DCOUNT(IS) + 1 !Count one more.
L2 = L(IS) + DCOUNT(IS) !Finger the next position.
IF (L2.GT.LST(IS)) CYCLE DD !If we're off the end, we're done.
D = ENTRYTEXT(WOT(IS))(L2:L2) !Otherwise, grab the character.
IF (D.LT."0" .OR. D.GT."9") CYCLE DD !Not a digit: done counting.
GO TO 20 !Otherwise, keep on looking.
END DO DD !On to the other text.
END IF !Righto, I now know how many digits are in each sequence.
Choose the shorter, and notionally insert a leading zero for it to be matched against the longer's digit..
IF (DCOUNT(1).LT.DCOUNT(2)) THEN !Righto, if the first has fewer digits,
DCOUNT(2) = DCOUNT(2) - 1 !Then only the second's digit will be used up.
L(1) = L(1) - 1 !Step back to re-encounter this next time.
C(1) = "0" !And create a leading zero from nothing.
ELSE IF (DCOUNT(2).LT.DCOUNT(1)) THEN !Likewise if the other way around.
DCOUNT(1) = DCOUNT(1) - 1 !The scan will consume this side's digit.
L(2) = L(2) - 1 !The next time here (if there is one)
C(2) = "0" !Will find a reduced difference in length.
ELSE !But if both have the same number of digits remaining,
DCOUNT = DCOUNT - 1 !They are used in parallel.
END IF !Perhaps even equal digit remnants.
END IF !Thus, arbitrary-size numbers are allowed, as they're never numbers.
END SUBROUTINE ANOTHER !Characters are announced in array C, moods in array STATE.
SUBROUTINE LIBRARIAN !Looks for texts starting "The ..." or "An ..." or "A ...", library style.
Checks the starts of the two texts, skipping leading spaceish stuff.
INTEGER IS,A,I !Steppers.
CHARACTER*1 C !A character to mess with.
EE:DO IS = 1,2 !Two texts to inspect.
TAIL(IS) = 0 !Nothing special found.
10 L(IS) = L(IS) + 1 !Advance one.
IF (L(IS).GT.LST(IS)) CYCLE EE !Run out of text?
IF (ENTRYTEXT(WOT(IS))(L(IS):L(IS)).LE." ") GO TO 10 !Scoot through leading space stuff.
AA:DO A = 1,3 !Now step through the known articles.
DO I = 0,A !Character by character thereof, with one trailing space.
IF (L(IS) + I.GT.LST(IS)) CYCLE EE !Have I a character to probe?
C = ENTRYTEXT(WOT(IS))(L(IS) + I:L(IS) + I) !Yes. Grab it.
CALL CRUSH(C) !Simplify.
IF (C.NE.ARTICLE(A)(1 + I:1 + I)) CYCLE AA !Mismatch? Try another.
END DO !On to the next character of ARTICLE(A).
TAIL(IS) = A !A match!
L(IS) = L(IS) + I !Finger the first character after the space.
CYCLE EE !Finished with this text. Also, BORED.
END DO AA !Try the next article..
END DO EE !Try the next text.
END SUBROUTINE LIBRARIAN !Ah, catalogue order. Blah, The.
END FUNCTION NATURALORDER !Not natural to a computer.
SUBROUTINE ORDERENTRY(LIST,N,WOTORDER) !Sorts the list according to the ordering function.
Crank up a Comb sort of the entries fingered by LIST. Working backwards, just for fun.
Caution: the H*10/13 means that H ought not be INTEGER*2. Otherwise, use H/1.3.
INTEGER LIST(*) !This is an index to the items being compared.
INTEGER T !In the absence of a SWAP(a,b). Same type as LIST.
INTEGER N !The number of entries.
EXTERNAL WOTORDER !A function to compare two entries.
INTEGER WOTORDER !Returns an integer result, on principle.
INTEGER I,H !Tools. H ought not be a small integer.
LOGICAL CURSE !Annoyance.
H = N - 1 !Last - First, and not +1.
IF (H.LE.0) RETURN !Ha ha.
1 H = MAX(1,H*10/13) !The special feature.
IF (H.EQ.9 .OR. H.EQ.10) H = 11 !A twiddle.
CURSE = .FALSE. !So far, so good.
DO I = N - H,1,-1 !If H = 1, this is a BubbleSort.
IF (WOTORDER(LIST(I),LIST(I + H)) .LT. 0) THEN !One compare.
T=LIST(I); LIST(I)=LIST(I+H); LIST(I+H)=T !One swap.
CURSE = .TRUE. !One curse.
END IF !One test.
END DO !One loop.
IF (CURSE .OR. H.GT.1) GO TO 1 !Work remains?
END SUBROUTINE ORDERENTRY!Fast enough, and simple.
END MODULE COMPOUND !Enough.
PROGRAM MR NATURAL !Presents a list in sorted order.
USE ASSISTANCE !Often needed.
USE COMPOUND !Deals with text in a complicated way.
USE BADCHARACTER !Some characters wreck the layout.
INTEGER ITEM(30),FANCY(30)!Two sets of indices.
INTEGER I,IT,TI !Assistants.
I = 0 !An array must have equal-length items, so trailing spaces would result.
I=I+1;ITEM(I) = ADDENTRY("ignore leading spaces: 2-2")
I=I+1;ITEM(I) = ADDENTRY(" ignore leading spaces: 2-1")
I=I+1;ITEM(I) = ADDENTRY(" ignore leading spaces: 2+0")
I=I+1;ITEM(I) = ADDENTRY(" ignore leading spaces: 2+1")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2-2")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2-1")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2+0")
I=I+1;ITEM(I) = ADDENTRY("ignore m.a.s spaces: 2+1")
I=I+1;ITEM(I) = ADDENTRY("Equiv."//" "//"spaces: 3-3")
I=I+1;ITEM(I) = ADDENTRY("Equiv."//CR//"spaces: 3-2") !CR can't appear as itself.
I=I+1;ITEM(I) = ADDENTRY("Equiv."//FF//"spaces: 3-1") !As it is used to mark line endings.
I=I+1;ITEM(I) = ADDENTRY("Equiv."//VT//"spaces: 3+0") !And if typed in an editor,
I=I+1;ITEM(I) = ADDENTRY("Equiv."//LF//"spaces: 3+1") !It is acted upon there and then.
I=I+1;ITEM(I) = ADDENTRY("Equiv."//HT//"spaces: 3+2") !So, name instead of value.
I=I+1;ITEM(I) = ADDENTRY("cASE INDEPENDENT: 3-2")
I=I+1;ITEM(I) = ADDENTRY("caSE INDEPENDENT: 3-1")
I=I+1;ITEM(I) = ADDENTRY("casE INDEPENDENT: 3+0")
I=I+1;ITEM(I) = ADDENTRY("case INDEPENDENT: 3+1")
I=I+1;ITEM(I) = ADDENTRY("foo100bar99baz0.txt")
I=I+1;ITEM(I) = ADDENTRY("foo100bar10baz0.txt")
I=I+1;ITEM(I) = ADDENTRY("foo1000bar99baz10.txt")
I=I+1;ITEM(I) = ADDENTRY("foo1000bar99baz9.txt")
I=I+1;ITEM(I) = ADDENTRY("The Wind in the Willows")
I=I+1;ITEM(I) = ADDENTRY("The 40th step more")
I=I+1;ITEM(I) = ADDENTRY("The 39 steps")
I=I+1;ITEM(I) = ADDENTRY("Wanda")
c I=I+1;ITEM(I) = ADDENTRY("A Dinosaur Grunts: Fortran Emerges")
c I=I+1;ITEM(I) = ADDENTRY("The Joy of Text Twiddling with Fortran")
c I=I+1;ITEM(I) = ADDENTRY("An Abundance of Storage Enables Waste")
c I=I+1;ITEM(I) = ADDENTRY("Theory Versus Practice: The Chasm")
WRITE (MSG,*) "nEntry=",NENTRY !Reach into the compound storage area.
FANCY = ITEM !Copy the list of entries.
ENTRYKEY = "" !To be written to by NATURALORDER.
CALL ORDERENTRY(FANCY,NENTRY,NATURALORDER) !"Natural" order.
CALL ORDERENTRY(ITEM,NENTRY,TEXTORDER) !Plain text order.
WRITE (MSG,1) "Character","'Natural'","N.Key" !Provide a heading.
1 FORMAT (3("Entry|Text ",A9," Order",16X)) !Usual trickery.
DO I = 1,NENTRY !Step through the lot.
IT = ITEM(I) !Saving on some typing.
TI = FANCY(I) !Presenting two lists, line by line.
WRITE (MSG,2) IT,DEFANG(ENTRYTEXT(IT)(1:ENTRYLENGTH(IT))) !Plain order,
1 ,TI,DEFANG(ENTRYTEXT(TI)(1:ENTRYLENGTH(TI))) !Followed by natural order.
2 ,TI,ENTRYKEY(TI) !Already defanged.
2 FORMAT (3(I5,"|",A36)) !This follows function ENTRYTEXT.
END DO !On to the next.
END !A handy hint from Mr. Natural: "At home or at work, get the right tool for the job!"

19
Task/Natural-sorting/JavaScript/natural-sorting.js Normal file
View file

@ -0,0 +1,19 @@
var nsort = function(input) {
var e = function(s) {
return (' ' + s + ' ').replace(/[\s]+/g, ' ').toLowerCase().replace(/[\d]+/, function(d) {
d = '' + 1e20 + d;
return d.substring(d.length - 20);
});
};
return input.sort(function(a, b) {
return e(a).localeCompare(e(b));
});
};
console.log(nsort([
"file10.txt",
"\nfile9.txt",
"File11.TXT",
"file12.txt"
]));
// -> ['\nfile9.txt', 'file10.txt', 'File11.TXT', 'file12.txt']

244
Task/Natural-sorting/Pascal/natural-sorting.pascal Normal file
View file

@ -0,0 +1,244 @@
Program Natural; Uses DOS, crt; {Simple selection.}
{Demonstrates a "natural" order of sorting text with nameish parts.}
Const null=#0; BS=#8; HT=#9; LF=#10{0A}; VT=#11{0B}; FF=#12{0C}; CR=#13{0D};
Procedure Croak(gasp: string);
Begin
WriteLn(Gasp);
HALT;
End;
Function Space(n: integer): string; {Can't use n*" " either.}
var text: string; {A scratchpad.}
var i: integer; {A stepper.}
Begin
if n > 255 then n:=255 {A value parameter,}
else if n < 0 then n:=0; {So this just messes with my copy.}
for i:=1 to n do text[i]:=' '; {Place some spaces.}
text[0]:=char(n); {Place the length thereof.}
Space:=text; {Take that.}
End; {of Space.}
Function DeFang(x: string): string; {Certain character codes cause action.}
var text: string; {A scratchpad, as using DeFang directly might imply recursion.}
var i: integer; {A stepper.}
var c: char; {Reduce repetition.}
Begin {I hope that appending is recognised by the compiler...}
text:=''; {Scrub the scratchpad.}
for i:=1 to Length(x) do {Step through the source text.}
begin {Inspecting each character.}
c:=char(x[i]); {Grab it.}
if c > CR then text:=text + c {Deemed not troublesome.}
else if c < BS then text:=text + c {Lacks an agreed alternative, and may not cause trouble.}
else text:=text + '!' + copy('btnvfr',ord(c) - ord(BS) + 1,1); {The alternative codes.}
end; {On to the next.}
DeFang:=text; {Alas, the "escape" convention lengthens the text.}
End; {of DeFang.} {But that only mars the layout, rather than ruining it.}
Const mEntry = 66; {Sufficient for demonstrations.}
Type EntryList = array[0..mEntry] of integer; {Identifies texts by their index.}
var EntryText: array[1..mEntry] of string; {Inbto this array.}
var nEntry: integer; {The current number.}
Function AddEntry(x: string): integer; {Add another text to the collection.}
Begin {Could extend to checking for duplicates via a sorted list...}
if nEntry >= mEntry then Croak('Too many entries!'); {Perhaps not!}
inc(nEntry); {So, another.}
EntryText[nEntry]:=x; {Placed.}
AddEntry:=nEntry; {The caller will want to know where.}
End; {of AddEntry.}
Function TextOrder(i,j: integer): boolean; {This is easy.}
Begin {But despite being only one statement, and simple at that,}
TextOrder:=EntryText[i] <= EntryText[j]; {Begin...End is insisted upon.}
End; {of TextOrder.}
Function NaturalOrder(e1,e2: integer): boolean;{Not so easy.}
const Article: array[1..3] of string[4] = ('A ','AN ','THE '); {Each with its trailing space.}
Function Crush(var c: char): char; {Suppresses divergence.}
Begin {To simplify comparisons.}
if c <= ' ' then Crush:=' ' {Crush the fancy control characters.}
else Crush:=UpCase(c); {Also crush a < A or a > A or a = A questions.}
End; {of Crush.}
var Wot: array[1..2] of integer; {Which text is being fingered.}
var Tail: array[1..2] of integer; {Which article has been found at the start.}
var l,lst: array[1..2] of integer; {Finger to the current point, and last character.}
Procedure Librarian; {Initial inspection of the texts.}
var Blocked: boolean; {Further progress may be obstructed.}
var a,is,i: integer; {Odds and ends.}
label Hic; {For escaping the search when a match is complete.}
Begin {There are two texts to inspect.}
for is:=1 to 2 do {Treat them alike.}
begin {This is the first encounter.}
l[is]:=1; {So start the scan with the first character.}
Tail[is]:=0; {No articles found.}
while (l[is] <= lst[is]) and (EntryText[wot[is]][l[is]] <= ' ') do inc(l[is]); {Leading spaceish.}
for a:=1 to 3 do {Try to match an article at the start of the text.}
begin {Each article's text has a trailing space to be matched also.}
i:=0; {Start a for-loop, but with early escape in mind.}
Repeat {Compare successive characters, for i:=0 to a...}
if l[is] + i > lst[is] then Blocked:=true {Probed past the end of text?}
else Blocked:=Crush(EntryText[wot[is]][l[is] + i]) <> Article[a][i + 1]; {No. Compare capitals.}
inc(i); {Stepping on to the next character.}
Until Blocked or (i > a); {Conveniently, Length(Article[a]) = a.}
if not Blocked then {Was a mismatch found?}
begin {No!}
Tail[is]:=a; {So, identify the discovery.}
l[is]:=l[is] + i; {And advance the scan to whatever follows.}
goto Hic; {Escape so as to consider the other text.}
end; {Since two texts are being considered separately.}
end; {Sigh. no "Next a" or similar syntax.}
Hic:dec(l[is]); {Backstep one, ready to advance later.}
end; {Likewise, no "for is:=1 to 2 do ... Next is" syntax.}
End; {of Librarian.}
var c: array[1..2] of string[1]; {Selected by Advance for comparison.}
var d: integer; {Their difference.}
type moody = (Done,Bored,Grist,Numeric); {Might as well have some mnemonics.}
var Mood: array[1..2] of moody; {As the scan proceeds, moods vary.}
var depth: array[1..2] of integer; {Digit depth.}
Procedure Another; {Choose a pair of characters to compare.}
{Digit sequences are special! But periods are ignored, also signs, avoiding confusion over "+6" and " 6".}
var is: integer; {Selects from one text or the other.}
var ll: integer; {Looks past the text into any Article.}
var d: char; {Possibly a digit.}
Begin
for is:=1 to 2 do {Same treatment for both texts.}
begin {Find the next character, and taste it.}
repeat {If already bored, slog through any following spaces.}
inc(l[is]); {So, advance one character onwards.}
ll:=l[is] - lst[is]; {Compare to the end of the normal text.}
if ll <= 0 then c[is]:=Crush(EntryText[wot[is]][l[is]]) {Still in the normal text.}
else if Tail[is] <= 0 then c[is]:='' {Perhaps there is no tail.}
else if ll <= 2 then c[is]:=copy(', ',ll,1) {If there is, this is the junction.}
else if ll <= 2 + Tail[is] then c[is]:=copy(Article[Tail[is]],ll - 2,1) {And this the tail.}
else c[is]:=''; {Actually, the copy would do this.}
until not ((c[is] = ' ') and (Mood[is] = Bored)); {Thus pass multiple enclosed spaces, but not the first.}
if length(c[is]) <= 0 then Mood[is]:=Done {Perhaps we ran off the end, even of the tail.}
else if c[is] = ' ' then Mood[is]:=Bored {The first taste of a space induces boredom.}
else if ('0' <= c[is]) and (c[is] <= '9') then Mood[is]:=Numeric {Paired, evokes special attention.}
else Mood[is]:=Grist; {All else is grist for my comparisons.}
end; {Switch to the next text.}
{Comparing digit sequences is to be done as if numbers. "007" vs "70" is to become vs. "070" by length matching.}
if (Mood[1] = Numeric) and (Mood[2] = Numeric) then {Are both texts yielding a digit?}
begin {Yes. Special treatment impends.}
if (Depth[1] = 0) and (Depth[2] = 0) then {Do I already know how many digits impend?}
for is:=1 to 2 do {No. So for each text,}
repeat {Keep looking until I stop seeing digits.}
inc(Depth[is]); {I am seeing a digit, so there will be one to count.}
ll:=l[is] + Depth[is]; {Finger the next position.}
if ll > lst[is] then d:=null {And if not off the end,}
else d:=EntryText[wot[is]][ll]; {Grab a potential digit.}
until (d < '0') or (d > '9'); {If it is one, probe again.}
if Depth[1] < Depth[2] then {Righto, if the first sequence has fewer digits,}
begin {Supply a free zero.}
dec(Depth[2]); {The second's digit will be consumed.}
dec(l[1]); {The first's will be re-encountered.}
c[1]:='0'; {Here is the zero}
end {For the comparison.}
else if Depth[2] < Depth[1] then {But if the second has fewer digits to come,}
begin {Don't dig into them yet.}
dec(Depth[1]); {The first's digit will be used.}
dec(l[2]); {But the second's seen again.}
c[2]:='0'; {After this has been used}
end {In the comparison.}
else {But if both have the same number of digits remaining,}
begin {Then the comparison is aligned.}
dec(Depth[1]); {So this digit will be used.}
dec(Depth[2]); {As will this.}
end; {In the comparison.}
end; {Thus, arbitrary-size numbers are allowed, as they're never numbers.}
End; {of Another.} {Possibly, the two characters will be the same, and another pair will be requested.}
Begin {of NaturalOrder.}
Wot[1]:=e1; Wot[2]:=e2; {Make the two texts accessible via indexing.}
lst[1]:=Length(EntryText[e1]); {The last character of the first text.}
lst[2]:=Length(EntryText[e2]); {And of the second. Saves on repetition.}
Mood[1]:=Bored; Mood[2]:=Bored; {Behave as if we have already seen a space.}
depth[1]:=0; depth[2]:=0; {And, no digits in concert have been seen.}
Librarian; {Start the inspection.}
repeat {Chug along, until a difference is found.}
Another; {To do so, choose another pair of characters to compare.}
d:=Length(c[2]) - Length(c[1]); {If one text has run out, favour the shorter.}
if (d = 0) and (Length(c[1]) > 0) then d:=ord(c[2][1]) - ord(c[1][1]); {Otherwise, their difference.}
until (d <> 0) or ((Mood[1] = Done) and (Mood[2] = Done)); {Well? Are we there yet?}
NaturalOrder:=d >= 0; {And so, does e1's text precede e2's?}
End; {of NatualOrder.}
var TextSort: boolean; {Because I can't pass a function as a parameter,}
Function InOrder(i,j: integer): boolean; {I can only use one function.}
Begin {Which messes with a selector.}
if TextSort then InOrder:=TextOrder(i,j) {So then,}
else InOrder:=NaturalOrder(i,j); {Which is it to be?}
End; {of InOrder.}
Procedure OrderEntry(var List: EntryList); {Passing a ordinary array is not Pascalish, damnit.}
{Crank up a Comb sort of the entries fingered by List. Working backwards, just for fun.}
{Caution: the H*10/13 means that H ought not be INTEGER*2. Otherwise, use H/1.3.}
var t: integer; {Same type as the elements of List.}
var N,i,h: integer; {Odds and ends.}
var happy: boolean; {To be attained.}
Begin
N:=List[0]; {Extract the count.}
h:=N - 1; {"Last" - "First", and not +1.}
if h <= 0 then exit; {Ha ha.}
Repeat {Start the pounding.}
h:=LongInt(h)*10 div 13; {Beware overflow, or, use /1.3.}
if h <= 0 then h:=1; {No "max" function, damnit.}
if (h = 9) or (h = 10) then h:=11; {A fiddle.}
happy:=true; {No disorder seen.}
for i:=N - h downto 1 do {So, go looking. If h = 1, this is a Bubblesort.}
if not InOrder(List[i],List[i + h]) then {How about this pair?}
begin {Alas.}
t:=List[i]; List[i]:=List[i + h]; List[i + h]:=t;{No Swap(a,b), damnit.}
happy:=false; {Disorder has been discovered.}
end; {On to the next comparison.}
Until happy and (h = 1); {No suspicion remains?}
End; {of OrderEntry.}
var Item,Fancy: EntryList; {Two lists of entry indices.}
var i: integer; {A stepper.}
var t1: string; {A scratchpad.}
BEGIN
nEntry:=0; {No entries are stored.}
i:=0; {Start a stepper.}
inc(i);Item[i]:=AddEntry('ignore leading spaces: 2-2');
inc(i);Item[i]:=AddEntry(' ignore leading spaces: 2-1');
inc(i);Item[i]:=AddEntry(' ignore leading spaces: 2+0');
inc(i);Item[i]:=AddEntry(' ignore leading spaces: 2+1');
inc(i);Item[i]:=AddEntry('ignore m.a.s spaces: 2-2');
inc(i);Item[i]:=AddEntry('ignore m.a.s spaces: 2-1');
inc(i);Item[i]:=AddEntry('ignore m.a.s spaces: 2+0');
inc(i);Item[i]:=AddEntry('ignore m.a.s spaces: 2+1');
inc(i);Item[i]:=AddEntry('Equiv.'+' '+'spaces: 3-3');
inc(i);Item[i]:=AddEntry('Equiv.'+CR+'spaces: 3-2'); {CR can't appear as itself.}
inc(i);Item[i]:=AddEntry('Equiv.'+FF+'spaces: 3-1'); {As it is used to mark line endings.}
inc(i);Item[i]:=AddEntry('Equiv.'+VT+'spaces: 3+0'); {And if typed in an editor,}
inc(i);Item[i]:=AddEntry('Equiv.'+LF+'spaces: 3+1'); {It is acted upon there and then.}
inc(i);Item[i]:=AddEntry('Equiv.'+HT+'spaces: 3+2'); {So, name instead of value.}
inc(i);Item[i]:=AddEntry('cASE INDEPENDENT: 3-2');
inc(i);Item[i]:=AddEntry('caSE INDEPENDENT: 3-1');
inc(i);Item[i]:=AddEntry('casE INDEPENDENT: 3+0');
inc(i);Item[i]:=AddEntry('case INDEPENDENT: 3+1');
inc(i);Item[i]:=AddEntry('foo100bar99baz0.txt');
inc(i);Item[i]:=AddEntry('foo100bar10baz0.txt');
inc(i);Item[i]:=AddEntry('foo1000bar99baz10.txt');
inc(i);Item[i]:=AddEntry('foo1000bar99baz9.txt');
inc(i);Item[i]:=AddEntry('The Wind in the Willows');
inc(i);Item[i]:=AddEntry('The 40th step more');
inc(i);Item[i]:=AddEntry('The 39 steps');
inc(i);Item[i]:=AddEntry('Wanda');
{inc(i);Item[i]:=AddEntry('The Worth of Wirth''s Way');}
Item[0]:=nEntry; {Complete the EntryList protocol.}
for i:=0 to nEntry do Fancy[i]:=Item[i]; {Sigh. Fancy:=Item.}
TextSort:=true; OrderEntry(Item); {Plain text ordering.}
TextSort:=false; OrderEntry(Fancy); {Natural order.}
WriteLn(' Text order Natural order');
for i:=1 to nEntry do
begin
t1:=DeFang(EntryText[Item[i]]);
WriteLn(Item[i]:3,'|',t1,Space(30 - length(t1)),' ',
Fancy[i]:3,'|',DeFang(EntryText[Fancy[i]]));
end;
END.

103
Task/Natural-sorting/Perl-6/natural-sorting.pl6 Normal file
View file

@ -0,0 +1,103 @@
# Sort groups of digits in number order. Sort by order of magnitude then lexically.
sub naturally ($a) { $a.lc.subst(/(\d+)/, ->$/ {0~$0.chars.chr~$0},:g) ~"\x0"~$a }
# Collapse multiple ws characters to a single.
sub collapse ($a) { $a.subst( / ( \s ) $0+ /, -> $/ { $0 }, :g ) }
# Convert all ws characters to a space.
sub normalize ($a) { $a.subst( / ( \s ) /, ' ', :g ) }
# Ignore common leading articles for title sorts
sub title ($a) { $a.subst( / :i ^ ( a | an | the ) >> \s* /, '' ) }
# Decompose ISO-Latin1 glyphs to their base character.
sub latin1_decompose ($a) {
$a.trans: <
Æ AE æ ae Þ TH þ th Ð TH ð th ß ss À A Á A Â A Ã A Ä A Å A à a á a
â a ã a ä a å a Ç C ç c È E É E Ê E Ë E è e é e ê e ë e Ì I Í I Î
I Ï I ì i í i î i ï i Ò O Ó O Ô O Õ O Ö O Ø O ò o ó o ô o õ o ö o
ø o Ñ N ñ n Ù U Ú U Û U Ü U ù u ú u û u ü u Ý Y ÿ y ý y
>.hash;
}
# Used as:
my @tests = (
[
"Task 1a\nSort while ignoring leading spaces.",
[
'ignore leading spaces: 1', ' ignore leading spaces: 4',
' ignore leading spaces: 3', ' ignore leading spaces: 2'
],
{.trim} # builtin method.
],
[
"Task 1b\nSort while ignoring multiple adjacent spaces.",
[
'ignore m.a.s spaces: 3', 'ignore m.a.s spaces: 1',
'ignore m.a.s spaces: 4', 'ignore m.a.s spaces: 2'
],
{.&collapse}
],
[
"Task 2\nSort with all white space normalized to regular spaces.",
[
"Normalized\tspaces: 4", "Normalized\xa0spaces: 1",
"Normalized\x20spaces: 2", "Normalized\nspaces: 3"
],
{.&normalize}
],
[
"Task 3\nSort case independently.",
[
'caSE INDEPENDENT: 3', 'casE INDEPENDENT: 2',
'cASE INDEPENDENT: 4', 'case INDEPENDENT: 1'
],
{.lc} # builtin method
],
[
"Task 4\nSort groups of digits in natural number order.",
[
<Foo100bar99baz0.txt foo100bar10baz0.txt foo1000bar99baz10.txt
foo1000bar99baz9.txt 201st 32nd 3rd 144th 17th 2 95>
],
{.&naturally}
],
[
"Task 5 ( mixed with 1, 2, 3 & 4 )\n"
~ "Sort titles, normalize white space, collapse multiple spaces to\n"
~ "single, trim leading white space, ignore common leading articles\n"
~ 'and sort digit groups in natural order.',
[
'The Wind in the Willows 8', ' The 39 Steps 3',
'The 7th Seal 1', 'Wanda 6',
'A Fish Called Wanda 5', ' The Wind and the Lion 7',
'Any Which Way But Loose 4', '12 Monkeys 2'
],
{.&normalize.&collapse.trim.&title.&naturally}
],
[
"Task 6, 7, 8\nMap letters in Latin1 that have accents or decompose to two\n"
~ 'characters to their base characters for sorting.',
[
<apple Ball bald car Card above Æon æon aether
niño nina e-mail Évian evoke außen autumn>
],
{.&latin1_decompose.&naturally}
]
);
for @tests -> $case {
my $code_ref = $case.pop;
my @array = $case.pop.list;
say $case.pop, "\n";
say "Standard Sort:\n";
.say for @array.sort;
say "\nNatural Sort:\n";
.say for @array.sort: {.$code_ref};
say "\n" ~ '*' x 40 ~ "\n";
}