      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!"


package main

import (
    "fmt"
    "regexp"
    "sort"
    "strconv"
    "strings"
)

var tests = []struct {
    descr string
    list  []string
}{
    {"Ignoring leading spaces", []string{
        "ignore leading spaces: 2-2",
        " ignore leading spaces: 2-1",
        "  ignore leading spaces: 2+0",
        "   ignore leading spaces: 2+1",
    }},
    {"Ignoring multiple adjacent spaces", []string{
        "ignore m.a.s spaces: 2-2",
        "ignore m.a.s  spaces: 2-1",
        "ignore m.a.s   spaces: 2+0",
        "ignore m.a.s    spaces: 2+1",
    }},
    {"Equivalent whitespace characters", []string{
        "Equiv. spaces: 3-3",
        "Equiv.\rspaces: 3-2",
        "Equiv.\fspaces: 3-1",
        "Equiv.\bspaces: 3+0",
        "Equiv.\nspaces: 3+1",
        "Equiv.\tspaces: 3+2",
    }},
    {"Case Indepenent sort", []string{
        "cASE INDEPENENT: 3-2",
        "caSE INDEPENENT: 3-1",
        "casE INDEPENENT: 3+0",
        "case INDEPENENT: 3+1",
    }},
    {"Numeric fields as numerics", []string{
        "foo100bar99baz0.txt",
        "foo100bar10baz0.txt",
        "foo1000bar99baz10.txt",
        "foo1000bar99baz9.txt",
    }},
}

func main() {
    for _, test := range tests {
        fmt.Println(test.descr)
        fmt.Println("Input order:")
        for _, s := range test.list {
            fmt.Printf("   %q\n", s)
        }
        fmt.Println("Natural order:")
        l := make(list, len(test.list))
        for i, s := range test.list {
            l[i] = newNatStr(s)
        }
        sort.Sort(l)
        for _, s := range l {
            fmt.Printf("   %q\n", s.s)
        }
        fmt.Println()
    }
}

// natStr associates a string with a preprocessed form
type natStr struct {
    s string // original
    t []tok  // preprocessed "sub-fields"
}

func newNatStr(s string) (t natStr) {
    t.s = s
    s = strings.ToLower(strings.Join(strings.Fields(s), " "))
    x := dx.FindAllString(s, -1)
    t.t = make([]tok, len(x))
    for i, s := range x {
        if n, err := strconv.Atoi(s); err == nil {
            t.t[i].n = n
        } else {
            t.t[i].s = s
        }
    }
    return t
}

var dx = regexp.MustCompile(`\d+|\D+`)

// rule is to use s unless it is empty, then use n
type tok struct {
    s string
    n int
}

// rule 2 of "numeric sub-fields" from talk page
func (f1 tok) Cmp(f2 tok) int {
    switch {
    case f1.s == "":
        switch {
        case f2.s > "" || f1.n < f2.n:
            return -1
        case f1.n > f2.n:
            return 1
        }
    case f2.s == "" || f1.s > f2.s:
        return 1
    case f1.s < f2.s:
        return -1
    }
    return 0
}

type list []natStr

func (l list) Len() int      { return len(l) }
func (l list) Swap(i, j int) { l[i], l[j] = l[j], l[i] }
func (l list) Less(i, j int) bool {
    ti := l[i].t
    for k, t := range l[j].t {
        if k == len(ti) {
            return true
        }
        switch ti[k].Cmp(t) {
        case -1:
            return true
        case 1:
            return false
        }
    }
    return false
}


import Data.List
import Data.Char
import Data.String.Utils
import Data.List.Utils
import Data.Function (on)

printOutput = do
                putStrLn "# Ignoring leading spaces \n"
                printBlockOfMessages sample1Rule ignoringStartEndSpaces
                putStrLn "\n # Ignoring multiple adjacent spaces (m.a.s) \n"
                printBlockOfMessages sample2Rule ignoringMultipleAdjacentSpaces
                putStrLn "\n # Equivalent whitespace characters \n"
                printBlockOfMessages sample3Rule ignoringMultipleAdjacentSpaces
                putStrLn "\n # Case Indepenent sorts \n"
                printBlockOfMessages sample4Rule caseIndependent
                putStrLn "\n # Numeric fields as numerics \n"
                printBlockOfMessages sample5Rule numericFieldsAsNumbers
                putStrLn "\n # Title sorts \n"
                printBlockOfMessages sample6Rule removeLeadCommonWords

printMessage message content = do
                 putStrLn message
                 mapM_ print content

printBlockOfMessages list function = do
      printMessage "Text strings:" list
      printMessage "Normally sorted:" (sort list)
      printMessage "Naturally sorted:" (sortListWith list function)

-- samples
sample1Rule = ["ignore leading spaces: 2-2", " ignore leading spaces: 2-1", "  ignore leading spaces: 2+0",  "   ignore leading spaces: 2+1"]
sample2Rule = ["ignore m.a.s spaces: 2-2", "ignore m.a.s  spaces: 2-1", "ignore m.a.s   spaces: 2+0", "ignore m.a.s    spaces: 2+1"]
sample3Rule = ["Equiv. spaces: 3-3", "Equiv.\rspaces: 3-2", "Equiv.\x0cspaces: 3-1", "Equiv.\x0bspaces: 3+0", "Equiv.\nspaces: 3+1", "Equiv.\tspaces: 3+2"]
sample4Rule = ["cASE INDEPENENT: 3-2", "caSE INDEPENENT: 3-1", "casE INDEPENENT: 3+0", "case INDEPENENT: 3+1"]
sample5Rule = ["foo100bar99baz0.txt", "foo100bar10baz0.txt", "foo1000bar99baz10.txt", "foo1000bar99baz9.txt"]
sample6Rule = ["The Wind in the Willows", "The 40th step more", "The 39 steps", "Wanda"]

-- function to execute all sorts
sortListWith l f = sort $ f l

-- 1. Ignore leading, trailing and multiple adjacent spaces

 -- Ignoring leading spaces

-- receive a String and remove all spaces from the start and end of that String, a String is considered an List os Char
-- ex: "  a string " = "a string"
ignoringStartEndSpaces :: [String] -> [String]
ignoringStartEndSpaces = map strip

-- Ignoring multiple adjacent spaces and Equivalent whitespace characters

ignoringMultipleAdjacentSpaces :: [String] -> [String]
ignoringMultipleAdjacentSpaces = map (unwords . words)

-- 2. Equivalent whitespace characters
-- 3. Case independent sort
-- lower case of an entire String
-- ex "SomeCAse" = "somecase"
caseIndependent :: [String] -> [String]
caseIndependent = map (map toLower)

-- 4. Numeric fields as numerics (deals with up to 20 digits)
numericFieldsAsNumbers :: [String] -> [[Int]]
numericFieldsAsNumbers = map findOnlyNumerics

findOnlyNumerics :: String -> [Int]
findOnlyNumerics s = convertDigitAsStringToInt $ makeListOfDigitsAsString $ extractDigitsAsString s
extractDigitsAsString :: String -> [String]
extractDigitsAsString s = map (filter isNumber) $ groupBy ((==) `on` isNumber ) s
makeListOfDigitsAsString :: [String] -> [String]
makeListOfDigitsAsString l = tail $ nub l
convertDigitAsStringToInt :: [String] -> [Int]
convertDigitAsStringToInt = map (joiner . map  digitToInt)

-- join a list of numbers into a single number
-- ex [4,2] = 42
joiner :: [Int] -> Int
joiner = read . concatMap show

-- 5. Title sort
removeLeadCommonWords l = map removeLeadCommonWord $ splitList l

splitList = map words
removeLeadCommonWord a = unwords $ if f a commonWords then tail a else a
                        where f l1 = elem (map toLower (head l1))
                              commonWords = ["the","a","an","of"]


require'strings regex'

lines=: <;.2
titleFix=: ('^\s*(the|a|an)\b';'')&rxrplc
isNum=: e.&'0123456789'
num=: ".^:([email protected]{.)
split=: <@num/.~ [:+/\1,2 ~:/\ isNum
norm=: [: split (32 9 12 13 14 15{a.) -.~ [: titleFix tolower

natSor=:  lines ;@/: norm&.>@lines


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']


DEFINE PTR="CARD"

PROC Wait(BYTE frames)
  BYTE RTCLOK=$14
  frames==+RTCLOK
  WHILE frames#RTCLOK DO OD
RETURN

PROC Main()
  BYTE AUDCTL=$D208,AUDF1=$D200,AUDC1=$D201,AUDF2=$D202,AUDC2=$D203
  PTR ARRAY notes(8)
  BYTE ARRAY pitch8=[60 53 47 45 40 35 31 30]
  CARD ARRAY pitch16=[1703 1517 1350 1274 1134 1010 899 848]
  BYTE i
  CARD p

  notes(0)="Do" notes(1)="Re" notes(2)="Mi" notes(3)="Fa"
  notes(4)="Sol" notes(5)="La" notes(6)="Si" notes(7)="Do"

  PrintE("8-bit precision pitch values:")
  FOR i=0 TO 7
  DO
    PrintF("%S-%B ",notes(i),pitch8(i))
    Sound(0,pitch8(i),10,10)
    Wait(20)
  OD
  SndRst()
  Wait(20)
  PutE() PutE()

  AUDCTL=$50 ;join channel 1 and 2 to get 16-bit
  AUDC1=$A0  ;turn off channel 1
  AUDC2=$AA  ;turn on channel 2
  PrintE("16-bit precision pitch values:")
  FOR i=0 TO 7
  DO
    PrintF("%S-%U ",notes(i),pitch16(i))
    p=pitch16(i)
    AUDF2=p RSH 8
    AUDF1=p&$FF
    Wait(20)
  OD
  SndRst()
  AUDCTL=$00 ;restore default configuration
  Wait(20)
RETURN


def splitup:
  def tidy: if .[0] == "" then .[1:] else . end | if .[length-1] == "" then .[0:length-1] else . end ;

  # a and b are assumed to be arrays:
  def alternate(a;b):
    reduce range(0; [a,b] | map(length) | max) as $i ([]; . + [a[$i], b[$i]]);

  ([splits("[0-9]+")] | tidy) as $a
  | ([splits("[^0-9]+")] | tidy | map(tonumber)) as $n
  | (test("^[0-9]")) as $nfirst
  | if $nfirst then alternate($n; $a) else alternate($a; $n) end ;

# The following implementation of tr is more general than needed here, but the generality
# makes for adaptability.
# x and y should both be strings defining a character-by-character translation, like Unix/Linux "tr".
# if y is shorter than x, then y will in effect be padded with y's last character.
# The input may be a string or an exploded string (i.e. an array);
# the output will have the same type as the input.
def tr(x;y):
  type as $type
  | (x | explode) as $xe
  | (y | explode) as $ye
  | $ye[-1] as $last
  | if $type == "string" then explode else . end
  | map( . as $n | ($xe|index($n)) as $i | if $i then $ye[$i]//$last else . end)
  | if $type == "string" then implode else . end;

# NOTE: the order in which the filters are applied is consequential!
def natural_sort:
  def naturally:
    gsub("\\p{M}"; "")         # combining characters (accents, umlauts, enclosures, etc)
    | tr("ÀÁÂÃÄÅàáâãäåÇçÈÉÊËèéêëÌÍÎÏìíîïÒÓÔÕÖØòóôõöøÑñÙÚÛÜùúûüÝÿý";
         "AAAAAAaaaaaaCcEEEEeeeeIIIIiiiiOOOOOOooooooNnUUUUuuuuYyy")
    # Ligatures:
    | gsub("Æ"; "AE")
    | gsub("æ"; "ae")
    | gsub("\u0132"; "IJ")     #  Ĳ
    | gsub("\u0133"; "ij")     #  ĳ
    | gsub("\u0152"; "Oe")     #  Œ
    | gsub("\u0153"; "oe")     #  œ
    | gsub("ﬄ"; "ffl")
    | gsub("ﬃ"; "ffi")
    | gsub("ﬁ" ; "fi")
    | gsub("ﬀ" ; "ff")
    | gsub("ﬂ" ; "fl")
    # Illustrative replacements:
    | gsub("ß" ; "ss")         # German scharfes S
    | gsub("ſ|ʒ"; "s")         # LATIN SMALL LETTER LONG S and LATIN SMALL LETTER EZH

    | ascii_downcase
    | gsub("\\p{Cc}+";" ")     # control characters
    | gsub("^(the|a|an) "; "") # leading the/a/an (as words)
    | gsub("\\s+"; " ")        # whitespace
    | sub("^ *";"")            # leading whitespace
    | sub(" *$";"")            # trailing whitespace
    | splitup                  # embedded integers
    ;
  sort_by(naturally);


#1
natural1(x, y) = strip(x) < strip(y)

#2
natural2(x, y) = replace(x, r"\s+" => " ") < replace(y, r"\s+" => " ")

#3
natural3(x, y) = lowercase(x) < lowercase(y)

#4
splitbynum(x) = split(x, r"(?<=\D)(?=\d)|(?<=\d)(?=\D)")
numstringtonum(arr) = [(n = tryparse(Float32, e)) != nothing ? n : e for e in arr]
function natural4(x, y)
    xarr = numstringtonum(splitbynum(x))
    yarr = numstringtonum(splitbynum(y))
    for i in 1:min(length(xarr), length(yarr))
        if typeof(xarr[i]) != typeof(yarr[i])
            a = string(xarr[i]); b = string(yarr[i])
        else
             a = xarr[i]; b = yarr[i]
        end
        if a == b
            continue
        else
            return a < b
        end
    end
    return length(xarr) < length(yarr)
end

#5
deart(x) = replace(x, r"^The\s+|^An\s+|^A\s+"i => "")
natural5(x, y) = deart(x) < deart(y)

#6
const accentdict = Dict(
'À'=> 'A', 'Á'=> 'A', 'Â'=> 'A', 'Ã'=> 'A', 'Ä'=> 'A',
'Å'=> 'A', 'Ç'=> 'C', 'È'=> 'E', 'É'=> 'E',
'Ê'=> 'E', 'Ë'=> 'E', 'Ì'=> 'I', 'Í'=> 'I', 'Î'=> 'I',
'Ï'=> 'I', 'Ñ'=> 'N', 'Ò'=> 'O', 'Ó'=> 'O',
'Ô'=> 'O', 'Õ'=> 'O', 'Ö'=> 'O', 'Ù'=> 'U', 'Ú'=> 'U',
'Û'=> 'U', 'Ü'=> 'U', 'Ý'=> 'Y', 'à'=> 'a', 'á'=> 'a',
'â'=> 'a', 'ã'=> 'a', 'ä'=> 'a', 'å'=> 'a', 'è'=> 'e',
'é'=> 'e', 'ê'=> 'e', 'ë'=> 'e', 'ì'=> 'i', 'í'=> 'i',
'î'=> 'i', 'ï'=> 'i', 'ð'=> 'd', 'ñ'=> 'n', 'ò'=> 'o',
'ó'=> 'o', 'ô'=> 'o', 'õ'=> 'o', 'ö'=> 'o', 'ù'=> 'u',
'ú'=> 'u', 'û'=> 'u', 'ü'=> 'u', 'ý'=> 'y', 'ÿ'=> 'y')
function tr(str, dict=accentdict)
    for (i, ch) in enumerate(str)
        if haskey(dict, ch)
            arr = split(str, "")
            arr[i] = string(dict[ch])
            str = join(arr)
        end
    end
    str
end

natural6(x, y) = tr(x) < tr(y)

#7
const ligaturedict = Dict('œ' => "oe", 'Œ' => "OE", 'æ' => "ae", 'Æ' => "AE", 'Ĳ' => "IJ")
natural7(x, y) = tr(x, ligaturedict) < tr(y, ligaturedict)

#8
const altsdict = Dict('ß' => "ss", 'ſ' => 's', 'ʒ' => 's')
natural8(x, y) = tr(x, altsdict) < tr(y, altsdict)

preprocessors = [natural1, natural2, natural2, natural3, natural4, natural5, natural6, natural7, natural8]

const testarrays = Vector{Vector{String}}([
["ignore leading spaces: 2-2", " ignore leading spaces: 2-1", "  ignore leading spaces: 2+0", "   ignore leading spaces: 2+1"],
["ignore m.a.s spaces: 2-2", "ignore m.a.s  spaces: 2-1", "ignore m.a.s   spaces: 2+0", "ignore m.a.s    spaces: 2+1"],
["Equiv. spaces: 3-3", "Equiv.\rspaces: 3-2", "Equiv.\x0cspaces: 3-1", "Equiv.\x0bspaces: 3+0", "Equiv.\nspaces: 3+1", "Equiv.\tspaces: 3+2"],
["cASE INDEPENENT: 3-2", "caSE INDEPENENT: 3-1", "casE INDEPENENT: 3+0", "case INDEPENENT: 3+1"],
["foo100bar99baz0.txt", "foo100bar10baz0.txt", "foo1000bar99baz10.txt", "foo1000bar99baz9.txt"],
["The Wind in the Willows", "The 40th step more", "The 39 steps", "Wanda"],
["Equiv. ý accents: 2-2", "Equiv. Ý accents: 2-1", "Equiv. y accents: 2+0", "Equiv. Y accents: 2+1"],
["Ĳ ligatured ij", "no ligature"],
["Start with an ʒ: 2-2", "Start with an ſ: 2-1", "Start with an ß: 2+0", "Start with an s: 2+1"]])

for (i, ltfunction) in enumerate(preprocessors)
    println("Testing sorting mod number $i. Sorted is: $(sort(testarrays[i], lt=ltfunction)).")
end


#include<stdio.h>
#include<conio.h>
#include<math.h>
#include<dos.h>

typedef struct{
	char str[3];
	int key;
	}note;

note sequence[] = {{"Do",0},{"Re",2},{"Mi",4},{"Fa",5},{"So",7},{"La",9},{"Ti",11},{"Do",12}};

int main(void)
{
	int i=0;

	while(!kbhit())
	{
		printf("\t%s",sequence[i].str);
		sound(261.63*pow(2,sequence[i].key/12.0));
		delay(sequence[i].key%12==0?500:1000);
		i = (i+1)%8;
		i==0?printf("\n"):printf("");
	}
	nosound();
	return 0;
}


// version 1.1.4-3

val r2 = Regex("""[ ]{2,}""")
val r3 = Regex("""\s""")  // \s represents any whitespace character
val r5 = Regex("""\d+""")

/** Only covers ISO-8859-1 accented characters plus (for consistency) Ÿ */
val ucAccented = arrayOf("ÀÁÂÃÄÅ", "Ç", "ÈÉÊË", "ÌÍÎÏ", "Ñ", "ÒÓÔÕÖØ", "ÙÚÛÜ", "ÝŸ")
val lcAccented = arrayOf("àáâãäå", "ç", "èéêë", "ìíîï", "ñ", "òóôõöø", "ùúûü", "ýÿ")
val ucNormal = "ACEINOUY"
val lcNormal = "aceinouy"

/** Only the commoner ligatures */
val ucLigatures = "ÆĲŒ"
val lcLigatures = "æĳœ"
val ucSeparated = arrayOf("AE", "IJ", "OE")
val lcSeparated = arrayOf("ae", "ij", "oe")

/** Miscellaneous replacements */
val miscLetters = "ßſʒ"
val miscReplacements = arrayOf("ss", "s", "s")

/** Displays strings including whitespace as if the latter were literal characters */
fun String.toDisplayString(): String {
    val whitespace  = arrayOf("\t", "\n", "\u000b", "\u000c", "\r")
    val whitespace2 = arrayOf("\\t", "\\n", "\\u000b", "\\u000c", "\\r")
    var s = this
    for (i in 0..4) s = s.replace(whitespace[i], whitespace2[i])
    return s
}

/** Ignoring leading space(s) */
fun selector1(s: String) = s.trimStart(' ')

/** Ignoring multiple adjacent spaces i.e. condensing to a single space */
fun selector2(s: String) = s.replace(r2, " ")

/** Equivalent whitespace characters (equivalent to a space say) */
fun selector3(s: String) = s.replace(r3, " ")

/** Case independent sort */
fun selector4(s: String) = s.toLowerCase()

/** Numeric fields as numerics (deals with up to 20 digits) */
fun selector5(s: String) = r5.replace(s) { it.value.padStart(20, '0') }

/** Title sort */
fun selector6(s: String): String {
    if (s.startsWith("the ", true)) return s.drop(4)
    if (s.startsWith("an ", true)) return s.drop(3)
    if (s.startsWith("a ", true)) return s.drop(2)
    return s
}

/** Equivalent accented characters (and case) */
fun selector7(s: String): String {
    val sb = StringBuilder()
    outer@ for (c in s) {
        for ((i, ucs) in ucAccented.withIndex()) {
            if (c in ucs) {
                sb.append(ucNormal[i])
                continue@outer
            }
        }
        for ((i, lcs) in lcAccented.withIndex()) {
            if (c in lcs) {
                sb.append(lcNormal[i])
                continue@outer
            }
        }
        sb.append(c)
    }
    return sb.toString().toLowerCase()
}

/** Separated ligatures */
fun selector8(s: String): String {
    var ss = s
    for ((i, c) in ucLigatures.withIndex()) ss = ss.replace(c.toString(), ucSeparated[i])
    for ((i, c) in lcLigatures.withIndex()) ss = ss.replace(c.toString(), lcSeparated[i])
    return ss
}

/** Character replacements */
fun selector9(s: String): String {
    var ss = s
    for ((i, c) in miscLetters.withIndex()) ss = ss.replace(c.toString(), miscReplacements[i])
    return ss
}

fun main(args: Array<String>) {
    println("The 9 string lists, sorted 'naturally':\n")
    val s1 = arrayOf(
        "ignore leading spaces: 2-2",
        " ignore leading spaces: 2-1",
        "  ignore leading spaces: 2+0",
        "   ignore leading spaces: 2+1"
    )
    s1.sortBy(::selector1)
    println(s1.map { "'$it'" }.joinToString("\n"))

    val s2 = arrayOf(
        "ignore m.a.s spaces: 2-2",
        "ignore m.a.s  spaces: 2-1",
        "ignore m.a.s   spaces: 2+0",
        "ignore m.a.s    spaces: 2+1"
    )
    println()
    s2.sortBy(::selector2)
    println(s2.map { "'$it'" }.joinToString("\n"))

    val s3 = arrayOf(
        "Equiv. spaces: 3-3",
        "Equiv.\rspaces: 3-2",
        "Equiv.\u000cspaces: 3-1",
        "Equiv.\u000bspaces: 3+0",
        "Equiv.\nspaces: 3+1",
        "Equiv.\tspaces: 3+2"
    )
    println()
    s3.sortBy(::selector3)
    println(s3.map { "'$it'".toDisplayString() }.joinToString("\n"))

    val s4 = arrayOf(
        "cASE INDEPENENT: 3-2",
        "caSE INDEPENENT: 3-1",
        "casE INDEPENENT: 3+0",
        "case INDEPENENT: 3+1"
    )
    println()
    s4.sortBy(::selector4)
    println(s4.map { "'$it'" }.joinToString("\n"))

    val s5 = arrayOf(
        "foo100bar99baz0.txt",
        "foo100bar10baz0.txt",
        "foo1000bar99baz10.txt",
        "foo1000bar99baz9.txt"
    )
    println()
    s5.sortBy(::selector5)
    println(s5.map { "'$it'" }.joinToString("\n"))

    val s6 = arrayOf(
        "The Wind in the Willows",
        "The 40th step more",
        "The 39 steps",
        "Wanda"
    )
    println()
    s6.sortBy(::selector6)
    println(s6.map { "'$it'" }.joinToString("\n"))

    val s7 = arrayOf(
        "Equiv. ý accents: 2-2",
        "Equiv. Ý accents: 2-1",
        "Equiv. y accents: 2+0",
        "Equiv. Y accents: 2+1"
    )
    println()
    s7.sortBy(::selector7)
    println(s7.map { "'$it'" }.joinToString("\n"))

    val s8 = arrayOf(
        "Ĳ ligatured ij",
        "no ligature"
    )
    println()
    s8.sortBy(::selector8)
    println(s8.map { "'$it'" }.joinToString("\n"))

    val s9 = arrayOf(
        "Start with an ʒ: 2-2",
        "Start with an ſ: 2-1",
        "Start with an ß: 2+0",
        "Start with an s: 2+1"
    )
    println()
    s9.sortBy(::selector9)
    println(s9.map { "'$it'" }.joinToString("\n"))
}


#include <iostream>
#include <windows.h>
#include <mmsystem.h>

#pragma comment ( lib, "winmm.lib" )

typedef unsigned char byte;

typedef union
{
    unsigned long word;
    unsigned char data[4];
}
midi_msg;

class midi
{
public:
    midi()
    {
	if( midiOutOpen( &device, 0, 0, 0, CALLBACK_NULL) != MMSYSERR_NOERROR )
	{
	    std::cout << "Error opening MIDI Output..." << std::endl;
	    device = 0;
	}
    }
    ~midi()
    {
	midiOutReset( device );
	midiOutClose( device );
    }
    bool isOpen() { return device != 0; }
    void setInstrument( byte i )
    {
	message.data[0] = 0xc0; message.data[1] = i;
	message.data[2] = 0; message.data[3] = 0;
	midiOutShortMsg( device, message.word );
    }
    void playNote( byte n, unsigned i )
    {
	playNote( n ); Sleep( i ); stopNote( n );
    }

private:
    void playNote( byte n )
    {
	message.data[0] = 0x90; message.data[1] = n;
	message.data[2] = 127; message.data[3] = 0;
	midiOutShortMsg( device, message.word );
    }
    void stopNote( byte n )
    {
	message.data[0] = 0x90; message.data[1] = n;
	message.data[2] = 0; message.data[3] = 0;
	midiOutShortMsg( device, message.word );
    }
    HMIDIOUT device;
    midi_msg message;
};

int main( int argc, char* argv[] )
{
    midi m;
    if( m.isOpen() )
    {
	byte notes[] = { 60, 62, 64, 65, 67, 69, 71, 72 };
	m.setInstrument( 42 );
	for( int x = 0; x < 8; x++ )
	    m.playNote( notes[x], rand() % 100 + 158 );
	Sleep( 1000 );
    }
    return 0;
}


import algorithm, parseutils, pegs, strutils, unidecode

type

  Kind = enum fString, fNumber

  KeyItem= object
    case kind: Kind
    of fString: str: string
    of fNumber: num: Natural

  Key = seq[KeyItem]

func cmp(a, b: Key): int =
  ## Compare two keys.

  for i in 0..<min(a.len, b.len):
    let ai = a[i]
    let bi = b[i]
    if ai.kind == bi.kind:
      result = if ai.kind == fString: cmp(ai.str, bi.str) else: cmp(ai.num, bi.num)
      if result != 0: return
    else:
      return if ai.kind == fString: 1 else: -1
  result = if a.len < b.len: -1 else: (if a.len == b.len: 0 else: 1)

proc natOrderKey(s: string): Key =
  ## Return the natural order key for a string.

  # Process 'ʒ' separately as "unidecode" converts it to 'z'.
  var s = s.replace("ʒ", "s")

  # Transform UTF-8 text into ASCII text.
  s = s.unidecode()

  # Remove leading and trailing white spaces.
  s = s.strip()

  # Make all whitespace characters equivalent and remove adjacent spaces.
  s = s.replace(peg"\s+", " ")

  # Switch to lower case.
  s = s.toLowerAscii()

  # Remove leading "the ".
  if s.startsWith("the ") and s.len > 4: s = s[4..^1]

  # Split into fields.
  var idx = 0
  var val: int
  while idx < s.len:
    var n = s.skipUntil(Digits, start = idx)
    if n != 0:
      result.add KeyItem(kind: fString, str: s[idx..<(idx + n)])
      inc idx, n
    n = s.parseInt(val, start = idx)
    if n != 0:
      result.add KeyItem(kind: fNumber, num: val)
      inc idx, n

proc naturalCmp(a, b: string): int =
  ## Natural order comparison function.
  cmp(a.natOrderKey, b.natOrderKey)

when isMainModule:

  proc test(title: string; list: openArray[string]) =
    echo title
    echo sorted(list, naturalCmp)
    echo ""

  test("Ignoring leading spaces.",
       ["ignore leading spaces:  2-2",
        "ignore leading spaces:  2-1",
        "ignore leading spaces:  2+0",
        "ignore leading spaces:  2+1"])

  test("Ignoring multiple adjacent spaces (MAS).",
       ["ignore MAS spaces:  2-2",
        "ignore MAS spaces:  2-1",
        "ignore MAS spaces:  2+0",
        "ignore MAS spaces:  2+1"])

  test("Equivalent whitespace characters.",
       ["Equiv.  spaces:     3-3",
        "Equiv. \rspaces:    3-2",
        "Equiv. \x0cspaces:  3-1",
        "Equiv. \x0bspaces:  3+0",
        "Equiv. \nspaces:    3+1",
        "Equiv. \tspaces:    3+2"])

  test("Case Independent sort.",
       ["cASE INDEPENDENT:  3-2",
        "caSE INDEPENDENT:  3-1",
        "casE INDEPENDENT:  3+0",
        "case INDEPENDENT:  3+1"])

  test("Numeric fields as numerics.",
       ["foo100bar99baz0.txt",
        "foo100bar10baz0.txt",
        "foo1000bar99baz10.txt",
        "foo1000bar99baz9.txt"])

  test("Title sorts.",
       ["The Wind in the Willows",
        "The 40th step more",
        "The 39 steps",
        "Wanda"])

  test("Equivalent accented characters (and case).",
       ["Equiv. ý accents:  2-2",
        "Equiv. Ý accents:  2-1",
        "Equiv. y accents:  2+0",
        "Equiv. Y accents:  2+1"])

  test("Separated ligatures.",
       ["Ĳ ligatured ij",
        "no ligature"])

  test("Character replacements.",
       ["Start with an ʒ:  2-2",
        "Start with an ſ:  2-1",
        "Start with an ß:  2+0",
        "Start with an s:  2+1"])


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.


(use 'overtone.live)

; Define your desired instrument
; Using saw-wave from: https://github.com/overtone/overtone/wiki/Chords-and-scales
(definst saw-wave [freq 440 attack 0.01 sustain 0.4 release 0.1 vol 0.4]
  (* (env-gen (env-lin attack sustain release) 1 1 0 1 FREE)
     (saw freq)
     vol))

(defn play [note ms]
  (saw-wave (midi->hz note))
  (Thread/sleep ms))

(doseq [note (scale :c4 :major)] (play note 500))


program Musical_scale;

{$APPTYPE CONSOLE}

uses
  Winapi.Windows;

var
  notes: TArray<Double> = [261.63, 293.66, 329.63, 349.23, 392.00, 440.00,
    493.88, 523.25];

begin
  for var note in notes do
    Beep(Round(note), 500);
  readln;
end.


use feature 'fc';
use Unicode::Normalize;

sub natural_sort {
    my @items = map {
        my $str = fc(NFKD($_));
        $str =~ s/\s+/ /;
        $str =~ s/|^(?:the|a|an) \b|\p{Nonspacing_Mark}| $//g;
        my @fields = $str =~ /(?!\z) ([^0-9]*+) ([0-9]*+)/gx;
        [$_, \@fields]
    } @_;
    return map { $_->[0] } sort {
        my @x = @{$a->[1]};
        my @y = @{$b->[1]};
        my $numeric;
        while (@x && @y) {
            my ($x, $y) = (shift @x, shift @y);
            return (($numeric = !$numeric) ? $x cmp $y : $x <=> $y or next);
        }
        return @x <=> @y;
    } @items;
}


(defun play-scale (freq-list dur)
  "Play a list of frequencies."
  (setq header (unibyte-string     ; AU header:
                  46 115 110 100   ;   ".snd" magic number
                  0 0 0 24         ;   start of data bytes
                  255 255 255 255  ;   file size is unknown
                  0 0 0 3          ;   16 bit PCM samples
                  0 0 172 68       ;   44,100 samples/s
                  0 0 0 1))        ;   mono
  (setq s nil)
  (dolist (freq freq-list)
    (setq v (mapcar (lambda (x)
                 (mod (round (* 32000 (sin (* 2 pi freq x (/ 44100.0))))) 65536))
                 (number-sequence 0 (* dur 44100))))
    (setq s (apply #'concat s (flatten-list (mapcar (lambda (x)
              (list (unibyte-string (ash x -8))
                    (unibyte-string (mod x 256))))
              v)))))
  (setq s (concat header s))
  (play-sound `(sound :data ,s)))

(play-scale '(261.63 293.66 329.63 349.23 392.00 440.00 493.88 523.25) .5)


HEX
\ PC speaker hardware control (requires giveio or DOSBOX for windows operation)
 042 constant fctrl        061 constant sctrl
 0FC constant smask        043 constant tctrl
 0B6 constant spkr

: sing      ( -- ) sctrl [email protected]               03 or  sctrl pc! ;
: silence   ( -- ) sctrl [email protected]   smask and   01 or  sctrl pc! ;

: tone     ( divisor -- )
            ?dup                                         \ check for non-zero input
            if   spkr  tctrl pc!                         \ enable PC speaker
                 dup   fctrl pc!                         \ load low byte
                 8 rshift fctrl pc!                      \ load high byte
                 sing
            else silence
            then ;

DECIMAL
1193181. 2constant clock                                 \ internal oscillator freq. MHz x 10

: Hz ( freq -- divisor) clock rot um/mod nip  ;          \ convert Freq to osc. divisor

\ duration control variables and values
variable on_time
variable off_time
variable feel                                            \ controls the on/off time ratio

60 value tempo

4000 tempo um* 2constant timebase                        \ 1 whole note=4000 ms @ 60 Beats/min

: bpm>ms    ( bpm -- ms) timebase rot um/mod nip ;       \ convert beats per minute to milliseconds
: wholenote ( -- ms )  tempo bpm>ms ;                    \ using tempo set the BPM

: play      ( divisor -- )
            tone on_time @ ms   silence  off_time @ ms ;

: expression ( ms n --)                                  \ adjust the on:off ratio using n
           over swap -  tuck -   ( -- on-mS off-mS )
           off_time !  on_time ! ;                       \ store times in variables

: note      ( -- ms ) on_time @ off_time @ + ;           \ returns duration of current note

: duration!    ( ms -- )  feel @ expression ;

: 50%       ( n -- n/2)    2/ ;
: %         ( n n2  -- n%) 100 */ ;                      \ calculate n2% of n
: 50%+      ( n -- n+50%)  dup 50% + ;                   \ dotted notes have 50% more time

VOCABULARY MUSIC

MUSIC DEFINITIONS
: BPM       ( bpm -- )                                  \ set tempo in beats per minute
            to tempo
            wholenote duration! ;

: legato      0 feel ! ;
: staccatto   note 8 %  feel ! ;
: Marcato     note 3 %  feel ! ;

: 1/1      wholenote      duration! ;
: 1/2      wholenote 50%  duration! ;
: 1/2.     1/2  note 50%+ duration! ;
: 1/4      1/2  note 50%  duration! ;
: 1/4.     1/4  note 50%+ duration! ;
: 1/8      1/4  note 50%  duration! ;
: 1/8.     1/8  note 50%+ duration! ;
: 1/16     1/8  note 50%  duration! ;
: 1/32     1/16 note 50%  duration! ;
: rest     note ms ;

\ note object creator
: note:    create  hz ,                    \ compile time: compile divisor into the note
           does>  @ play ;                 \ run time: fetch the value and play the tone

\ freq  Natural    Freq  Accidental    En-harmonic
\ -------------    ----------------   ----------------
  131 note: C3     139 note: C#3       synonym Db3 C#3
  147 note: D3     156 note: D#3       synonym Eb3 D#3
  165 note: E3
  175 note: F3     185 note: F#3       synonym Gb3 F#3
  196 note: G3     208 note: G#3       synonym Ab3 G#3
  220 note: A3     233 note: A#3       synonym Bb3 A#3
  247 note: B3
  262 note: C4     277 note: C#4       synonym Db4 C#4

: Cmajor      1/8  C3 D3 E3  F3 G3 A3  B3  C4 ;
: Chromatic   1/8  C3 C#3 D3 D#3 E3 F3 F#3 G3 G#3 A3 A#3 B3 C4 ;


REM FreeBASIC no tiene la capacidad de emitir sonido de forma nativa.
REM La función Sound no es mía, incluyo los créditos correspondientes.
' Sound Function v0.3 For DOS/Linux/Win by yetifoot
' Credits:
'    http://www.frontiernet.net/~fys/snd.htm
'    http://delphi.about.com/cs/adptips2003/a/bltip0303_3.htm
#ifdef __FB_WIN32__
#include Once "windows.bi"
#endif
Sub Sound_DOS_LIN(Byval freq As Uinteger, dur As Uinteger)
    Dim t As Double
    Dim As Ushort fixed_freq = 1193181 \ freq

    Asm
        mov  dx, &H61                  ' turn speaker on
        in   al, dx
        or   al, &H03
        out  dx, al
        mov  dx, &H43                  ' get the timer ready
        mov  al, &HB6
        out  dx, al
        mov  ax, word Ptr [fixed_freq] ' move freq to ax
        mov  dx, &H42                  ' port to out
        out  dx, al                    ' out low order
        xchg ah, al
        out  dx, al                    ' out high order
    End Asm

    t = Timer
    While ((Timer - t) * 1000) < dur ' wait for out specified duration
        Sleep(1)
    Wend

    Asm
        mov  dx, &H61                  ' turn speaker off
        in   al, dx
        and  al, &HFC
        out  dx, al
    End Asm
End Sub

Sub Sound(Byval freq As Uinteger, dur As Uinteger)
    #ifndef __fb_win32__
    ' If not windows Then call the asm version.
    Sound_DOS_LIN(freq, dur)
    #Else
    ' If Windows
    Dim osv As OSVERSIONINFO

    osv.dwOSVersionInfoSize = Sizeof(OSVERSIONINFO)
    GetVersionEx(@osv)

    Select Case osv.dwPlatformId
    Case VER_PLATFORM_WIN32_NT
        ' If NT then use Beep from API
        Beep_(freq, dur)
    Case Else
        ' If not on NT then use the same as DOS/Linux
        Sound_DOS_LIN(freq, dur)
    End Select
    #endif
End Sub

'----------
Sound(262, 250)  'C4
Sound(294, 250)  'D4
Sound(330, 250)  'E4
Sound(349, 250)  'F4
Sound(392, 250)  'G4
Sound(440, 250)  'A4
Sound(494, 250)  'B4
Sound(523, 250)  'C5
Sleep


{$mode objfpc}
uses windows,math;{ windows only }
var
  Interval:Double =  1.0594630943592953;
  i:integer;
begin
  for  i:= 0 to 11 do
    beep(Round(440.0*interval**i),500);
end.


package main

import (
    "encoding/binary"
    "log"
    "math"
    "os"
    "strings"
)

func main() {
    const (
        sampleRate = 44100
        duration   = 8
        dataLength = sampleRate * duration
        hdrSize    = 44
        fileLen    = dataLength + hdrSize - 8
    )

    // buffers
    buf1 := make([]byte, 1)
    buf2 := make([]byte, 2)
    buf4 := make([]byte, 4)

    // WAV header
    var sb strings.Builder
    sb.WriteString("RIFF")
    binary.LittleEndian.PutUint32(buf4, fileLen)
    sb.Write(buf4) // file size - 8
    sb.WriteString("WAVE")
    sb.WriteString("fmt ")
    binary.LittleEndian.PutUint32(buf4, 16)
    sb.Write(buf4) // length of format data (= 16)
    binary.LittleEndian.PutUint16(buf2, 1)
    sb.Write(buf2) // type of format (= 1 (PCM))
    sb.Write(buf2) // number of channels (= 1)
    binary.LittleEndian.PutUint32(buf4, sampleRate)
    sb.Write(buf4) // sample rate
    sb.Write(buf4) // sample rate * bps(8) * channels(1) / 8 (= sample rate)
    sb.Write(buf2) // bps(8) * channels(1) / 8  (= 1)
    binary.LittleEndian.PutUint16(buf2, 8)
    sb.Write(buf2) // bits per sample (bps) (= 8)
    sb.WriteString("data")
    binary.LittleEndian.PutUint32(buf4, dataLength)
    sb.Write(buf4) // size of data section
    wavhdr := []byte(sb.String())

    // write WAV header
    f, err := os.Create("notes.wav")
    if err != nil {
        log.Fatal(err)
    }
    defer f.Close()
    f.Write(wavhdr)

    // compute and write actual data
    freqs := [8]float64{261.6, 293.6, 329.6, 349.2, 392.0, 440.0, 493.9, 523.3}
    for j := 0; j < duration; j++ {
        freq := freqs[j]
        omega := 2 * math.Pi * freq
        for i := 0; i < dataLength/duration; i++ {
            y := 32 * math.Sin(omega*float64(i)/float64(sampleRate))
            buf1[0] = byte(math.Round(y))
            f.Write(buf1)
        }
    }
}


(de parseNatural (Str)
   (clip
      (make
         (for (L (chop Str)  L)
            (cond
               ((sp? (car L))
                  (link " ")
                  (while (and L (sp? (car L)))
                     (pop 'L) ) )
               ((>= "9" (car L) "0")
                  (link
                     (format
                        (make
                           (loop
                              (link (pop 'L))
                              (NIL (>= "9" (car L) "0")) ) ) ) ) )
               (T
                  (let Word
                     (pack
                        (replace
                           (make
                              (loop
                                 (link (lowc (pop 'L)))
                                 (NIL L)
                                 (T (sp? (car L)))
                                 (T (>= "9" (car L) "0")) ) )
                            "ß" "ss" "ſ" "s" "ʒ" "s" ) )
                     (unless (member Word '(the it to))
                        (link Word) ) ) ) ) ) ) ) )


# six sorting
$Discard = '^a ', '^an ', '^the '
$List =
   'ignore leading spaces: 2-2<==',
   ' ignore leading spaces: 2-1 <==',
   '  ignore leading spaces: 2+0  <==',
   '   ignore leading spaces: 2+1   <==',
   'ignore m.a.s spaces: 2-2<==',
   'ignore m.a.s  spaces: 2-1<==',
   'ignore m.a.s   spaces: 2+0<==',
   'ignore m.a.s    spaces: 2+1<==',
   'Equiv. spaces: 3-3<==',
   "Equiv.`rspaces: 3-2<==",
   "Equiv.`fspaces: 3-1<==",
   "Equiv.`vspaces: 3+0<==",
   "Equiv.`nspaces: 3+1<==",
   "Equiv.`tspaces: 3+2<==",
   'cASE INDEPENDENT: 3-2<==',
   'caSE INDEPENDENT: 3-1<==',
   'casE INDEPENDENT: 3+0<==',
   'case INDEPENDENT: 3+1<==',
   'Lâmpada accented characters<==',
   'Lúdico accented characters<==',
   '     Lula    Free   !!! accented characters<==',
   'Amanda accented characters<==',
   'Ágata accented characters<==',
   'Ångström accented characters<==',
   'Ângela accented characters<==',
   'À toa accented characters<==',
   'ânsia accented characters<==',
   'álibi accented characters<==',
   'foo100bar99baz0.txt<==',
   'foo100bar10baz0.txt<==',
   'foo1000bar99baz10.txt<==',
   'foo1000bar99baz9.txt<==',
   'The Wind in the Willows<==',
   'The 40th step more<==',
   'The 39 steps<==',
   'Wanda<=='

'List index sorting'
$List
' '
'Lexicographically sorting'
$List | Sort-Object
' '
'Natural sorting'
$List | Sort-Object -Property {
   [Regex]::Replace(
      (
         (
            & {
               If ($_.Trim() -match ($Discard -join '|')) {
                  $_ -replace '^\s*[^\s]+\s*'
               } Else {
                  $_.Trim()
               }
            }
         ) -replace '\s+'
      ), '\d+', { $args[0].Value.PadLeft(20) }
   )
}


require'media/wav'
0.25 wavnote 0 2 4 5 7 9 11 12


<!doctype html>
<html>
<head>
<meta charset="utf-8">
<title>Sample Page</title>
</head>
<body>
Upon loading the page you should hear the scale.
<script type="text/javascript">
function musicalScale(freqArr){
    // create web audio api context
    var AudioContext = window.AudioContext || window.webkitAudioContext;
    var audioCtx = new AudioContext();

    // create oscillator and gain node
    var oscillator = audioCtx.createOscillator();
    var gainNode = audioCtx.createGain();

    // connect oscillator to gain node to speakers
    oscillator.connect(gainNode);
    gainNode.connect(audioCtx.destination);

    // set frequencies to play
    duration = 0.5   // seconds
    freqArr.forEach(function (freq, i){
        oscillator.frequency.setValueAtTime(freq, audioCtx.currentTime + i * duration);
    });

    // start playing!
    oscillator.start();
    // stop playing!
    oscillator.stop(audioCtx.currentTime + freqArr.length * duration);
}

musicalScale([261.63, 293.66, 329.63, 349.23, 392.00, 440.00, 493.88, 523.25]);
</script>
</body>
</html>


using PortAudio

function paudio()
    devs = PortAudio.devices()
    devnum = findfirst(x -> x.maxoutchans > 0, devs)
    (devnum == nothing) && error("No output device for audio found")
    return PortAudioStream(devs[devnum].name, 0, 2)
end

function play(ostream, pitch, durationseconds)
    sinewave(t) = 0.6sin(t) + 0.2sin(2t) + .05sin(8t)
    timesamples = 0:(1 / 44100):(durationseconds * 0.98)
    v = Float64[sinewave(2π * pitch * t) for t in timesamples]
    write(ostream, v)
    sleep(durationseconds * 0.9)
end

# C major scale starting with middle C
# pitches from //pages.mtu.edu/~suits/notefreqs.html
const scale = [261.6, 293.7, 329.6, 349.2, 392, 440, 493.9, 523.3]
const ostream = paudio()
for pitch in scale
    play(ostream, pitch, 0.5)
    sleep(0.4)
end


// Kotlin Native v0.3

import kotlinx.cinterop.*
import win32.*

fun main(args: Array<String>) {
    val freqs = intArrayOf(262, 294, 330, 349, 392, 440, 494, 523)  // CDEFGABc
    val dur = 500
    repeat(5) { for (freq in freqs) Beep(freq, dur) }
}


# -*- coding: utf-8 -*-
# Not Python 3.x (Can't compare str and int)

from itertools import groupby
from unicodedata import decomposition, name
from pprint import pprint as pp

commonleaders = ['the'] # lowercase leading words to ignore
replacements = {u'ß': 'ss',  # Map single char to replacement string
                u'ſ': 's',
                u'ʒ': 's',
                }

hexdigits = set('0123456789abcdef')
decdigits = set('0123456789')   # Don't use str.isnumeric

def splitchar(c):
    ' De-ligature. De-accent a char'
    de = decomposition(c)
    if de:
        # Just the words that are also hex numbers
        de = [d for d in de.split()
                  if all(c.lower()
                         in hexdigits for c in d)]
        n = name(c, c).upper()
        # (Gosh it's onerous)
        if len(de)> 1 and 'PRECEDE' in n:
            # E.g. ŉ  LATIN SMALL LETTER N PRECEDED BY APOSTROPHE
            de[1], de[0] = de[0], de[1]
        tmp = [ unichr(int(k, 16)) for k in de]
        base, others = tmp[0], tmp[1:]
        if 'LIGATURE' in n:
            # Assume two character ligature
            base += others.pop(0)
    else:
        base = c
    return base

def sortkeygen(s):
    '''Generate 'natural' sort key for s

    Doctests:
        >>> sortkeygen('  some extra    spaces  ')
        [u'some extra spaces']
        >>> sortkeygen('CasE InseNsItIve')
        [u'case insensitive']
        >>> sortkeygen('The Wind in the Willows')
        [u'wind in the willows']
        >>> sortkeygen(u'\462 ligature')
        [u'ij ligature']
        >>> sortkeygen(u'\335\375 upper/lower case Y with acute accent')
        [u'yy upper/lower case y with acute accent']
        >>> sortkeygen('foo9.txt')
        [u'foo', 9, u'.txt']
        >>> sortkeygen('x9y99')
        [u'x', 9, u'y', 99]
    '''
    # Ignore leading and trailing spaces
    s = unicode(s).strip()
    # All space types are equivalent
    s = ' '.join(s.split())
    # case insentsitive
    s = s.lower()
    # Title
    words = s.split()
    if len(words) > 1 and words[0] in commonleaders:
        s = ' '.join( words[1:])
    # accent and ligatures
    s = ''.join(splitchar(c) for c in s)
    # Replacements (single char replaced by one or more)
    s = ''.join( replacements.get(ch, ch) for ch in s )
    # Numeric sections as numerics
    s = [ int("".join(g)) if isinteger else "".join(g)
          for isinteger,g in groupby(s, lambda x: x in decdigits)]

    return s

def naturalsort(items):
    ''' Naturally sort a series of strings

    Doctests:
        >>> naturalsort(['The Wind in the Willows','The 40th step more',
                         'The 39 steps', 'Wanda'])
        ['The 39 steps', 'The 40th step more', 'Wanda', 'The Wind in the Willows']

    '''
    return sorted(items, key=sortkeygen)

if __name__ == '__main__':
    import string

    ns = naturalsort

    print '\n# Ignoring leading spaces'
    txt = ['%signore leading spaces: 2%+i' % (' '*i, i-2) for i in range(4)]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Ignoring multiple adjacent spaces (m.a.s)'
    txt = ['ignore m.a.s%s spaces: 2%+i' % (' '*i, i-2) for i in range(4)]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Equivalent whitespace characters'
    txt = ['Equiv.%sspaces: 3%+i' % (ch, i-3)
           for i,ch in enumerate(reversed(string.whitespace))]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Case Indepenent sort'
    s = 'CASE INDEPENENT'
    txt = [s[:i].lower() + s[i:] + ': 3%+i' % (i-3) for i in range(1,5)]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Numeric fields as numerics'
    txt = ['foo100bar99baz0.txt', 'foo100bar10baz0.txt',
           'foo1000bar99baz10.txt', 'foo1000bar99baz9.txt']
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Title sorts'
    txt = ['The Wind in the Willows','The 40th step more',
                         'The 39 steps', 'Wanda']
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Equivalent accented characters (and case)'
    txt = ['Equiv. %s accents: 2%+i' % (ch, i-2)
           for i,ch in enumerate(u'\xfd\xddyY')]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Separated ligatures'
    txt = [u'\462 ligatured ij', 'no ligature',]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; pp(sorted(txt))
    print 'Naturally sorted:'; pp(ns(txt))

    print '\n# Character replacements'
    s = u'ʒſßs' # u'\u0292\u017f\xdfs'
    txt = ['Start with an %s: 2%+i' % (ch, i-2)
           for i,ch in enumerate(s)]
    print 'Text strings:'; pp(txt)
    print 'Normally sorted :'; print '\n'.join(sorted(txt))
    print 'Naturally sorted:'; print '\n'.join(ns(txt))


% Start at middle C
\relative c' {
  c d e f
  g a b c
}


10 mode 1
20 print "Note","Freq. (Hz)","Period"
30 ' program loop:
40 if sq(1)<128 then gosub 70  ' play next note if channel is inactive
50 goto 40
60 ' play next note
70 read n
80 if n<0 then end
90 note=note+1
100 ' calculation from chapter 7, page 26 of the CPC manual:
110 f=440*(2^((n-10)/12))
120 p=round(62500/f)
130 print mid$("cdefgabc",note,1),round(f,2),p
140 sound 1,p,100
150 return
160 data 1,3,5,6,8,10,12,13,-1


c = string.char
midi = "MThd" .. c(0,0,0,6,0,0,0,1,0,96) -- header
midi = midi .. "MTrk" .. c(0,0,0,8*8+4) -- track
for _,note in ipairs{60,62,64,65,67,69,71,72} do
  midi = midi .. c(0, 0x90, note, 0x40, 0x60, 0x80, note, 0) -- notes
end
midi = midi .. c(0, 0xFF, 0x2F, 0) -- end

file = io.open("scale.mid", "wb")
file:write(midi)
file:close()

-- (optional:  hex dump to screen)
midi:gsub(".", function(c) io.write(string.format("%02X ", string.byte(c))) end)


#lang racket
(define (natural-sort l)
  (define (list<? l1 l2)
    (cond [(null? l2) #f]
          [(null? l1) #t]
          [(number? (car l1)) (cond [(< (car l1) (car l2)) #t]
                                    [(< (car l2) (car l1)) #f]
                                    [else (list<? (cdr l1) (cdr l2))])]
          [(string? (car l1)) (cond [(string<? (car l1) (car l2)) #t]
                                    [(string<? (car l2) (car l1)) #f]
                                    [else (list<? (cdr l1) (cdr l2))])]))
  (define (->keys s)
    (define s* (string-normalize-spaces (string-foldcase s)))
    (for/list ([x (regexp-match* #px"\\d+" s* #:gap-select? #t)]
               [i (in-naturals)])
      (if (odd? i) (string->number x) x)))
  (sort l list<? #:key ->keys #:cache-keys? #t))

(natural-sort
 (shuffle '("foo9.txt" "foo10.txt" "x9y99" "x9y100" "x10y0" "x  z" "x y")))
;; => '("foo9.txt" "foo10.txt" "x9y99" "x9y100" "x10y0" "x y" "x  z")


# 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";
}


Module checkit {
      \\ using internal speaker
      TUNE 300, "C3DEFGABC4"
      TUNE 300, "C3C#DD#EFF#GG#AA#BC4"
      Thread {
            score 10, 100,  "CAC"
            Play 10, 1
      } as drums interval 1000
      \\ Play in background (16 scores - no 10 for drum machine)
      SCORE 1, 300, "C3DEFGABC4"
      PLAY 1, 19  ' use score 1 with organ 19
      Wait 2400
}
checkit


import endians, math

const
  SampleRate = 44100
  Duration = 8
  DataLength = SampleRate * Duration
  HdrSize = 44
  FileLen = DataLength + HdrSize - 8
  Bps = 8
  Channels = 1

proc writeUint16(f: File; x: uint16) =
  var x = x
  var y: array[2, byte]
  littleEndian16(y.addr, x.addr)
  let n = f.writeBytes(y, 0, 2)
  doAssert n == 2

proc writeUint32(f: File; x: uint32) =
  var x = x
  var y: array[4, byte]
  littleEndian32(y.addr, x.addr)
  let n = f.writeBytes(y, 0, 4)
  doAssert n == 4

let file = open("notes.wav", fmWrite)

# Wav header.
file.write "RIFF"
file.writeUint32(FileLen)
file.write "WAVE"
file.write "fmt "
file.writeUint32(16)                # length of format data.
file.writeUint16(1)                 # type of format(PCM).
file.writeUint16(Channels)
file.writeUint32(SampleRate)
file.writeUint32(SampleRate * Bps * Channels div 8)
file.writeUint16(Bps * Channels div 8)
file.writeUint16(Bps)
file.write "data"
file.writeUint32(DataLength)        # size of data section.

# Compute and write actual data.
const Freqs = [261.6, 293.6, 329.6, 349.2, 392.0, 440.0, 493.9, 523.3]
for freq in Freqs:
  let omega = 2 * Pi * freq
  for i in 0..<(DataLength div Duration):
    let y = (32 * sin(omega * i.toFloat / SampleRate.toFloat)).toInt
    file.write chr(y.byte)  # Signed int to byte then to char as it’s easier this way.

file.close()


/* REXX ---------------------------------------------------------------
* 24.02.2013 Walter Pachl derived from original REXX version
* Changes: sound(f,sec) --> beep(trunc(f),millisec)
*          $ -> sc
*          @. -> f.
*          re > ra (in sc)
*--------------------------------------------------------------------*/
  sc='do ra mi fa so la te do'
  dur=1250                          /* milliseconds                   */
  Do j=1 For words(sc)              /* sound each "note" in the string*/
    Call notes word(sc,j),dur       /* invoke a subroutine for sounds.*/
    End                             /* j                              */
  Exit                              /* stick a fork in it, we're done.*/
notes: Procedure
  Arg note,dur
  f.=0                              /* define common names for sounds.*/
  f.la=220
  f.si=246.94
  f.te=f.si
  f.ta=f.te
  f.ti=f.te
  f.do=261.6256
  f.ut=f.do
  f.ra=293.66
  f.re=f.ra     /* re is to be a synonym for ra */
  f.mi=329.63
  f.ma=f.mi
  f.fa=349.23
  f.so=392
  f.sol=f.so
  Say note trunc(f.note) dur
  If f.note\==0 Then
    Call beep trunc(f.note),dur     /* sound the "note".              */
  Return


ar.sort_by{|str| str.downcase.gsub(/\Athe |\Aa |\Aan /, "").lstrip.gsub(/\s+/, " ")}


object NaturalSorting {
  implicit object ArrayOrdering extends Ordering[Array[String]] { // 4
    val INT = "([0-9]+)".r
    def compare(a: Array[String], b: Array[String]) = {
      val l = Math.min(a.length, b.length)
      (0 until l).prefixLength(i => a(i) equals b(i)) match {
        case i if i == l => Math.signum(b.length - a.length).toInt
        case i => (a(i), b(i)) match {
          case (INT(c), INT(d)) => Math.signum(c.toInt - d.toInt).toInt
          case (c, d) => c compareTo d
        }
      }
    }
  }

  def natural(s: String) = {
    val replacements = Map('\u00df' -> "ss", '\u017f' -> "s", '\u0292' -> "s").withDefault(s => s.toString) // 8
    import java.text.Normalizer
    Normalizer.normalize(Normalizer.normalize(
      s.trim.toLowerCase, // 1.1, 1.2, 3
      Normalizer.Form.NFKC), // 7
      Normalizer.Form.NFD).replaceAll("[\\p{InCombiningDiacriticalMarks}]", "") // 6
     .replaceAll("^(the|a|an) ", "") // 5
     .flatMap(replacements.apply) // 8
     .split(s"\\s+|(?=[0-9])(?<=[^0-9])|(?=[^0-9])(?<=[0-9])") // 1.3, 2 and 4
  }
}

object NaturalSortingTest extends App {
  import NaturalSorting._

  val tests = List(
    ("1 Ignoring leading spaces", List("ignore leading spaces: 2-2", " ignore leading spaces: 2-1", "  ignore leading spaces: 2+0", "   ignore leading spaces: 2+1"), List("  ignore leading spaces: 2+0", "   ignore leading spaces: 2+1", " ignore leading spaces: 2-1", "ignore leading spaces: 2-2")),
    ("1 Ignoring multiple adjacent spaces (m.a.s)", List("ignore m.a.s spaces: 2-2", "ignore m.a.s  spaces: 2-1", "ignore m.a.s   spaces: 2+0", "ignore m.a.s  spaces: 2+1"), List("ignore m.a.s   spaces: 2+0", "ignore m.a.s  spaces: 2+1", "ignore m.a.s  spaces: 2-1", "ignore m.a.s spaces: 2-2")),
    ("2 Equivalent whitespace characters", List("Equiv. spaces: 3-3", "Equiv.\rspaces: 3-2", "Equiv.\u000cspaces: 3-1", "Equiv.\u000bspaces: 3+0", "Equiv.\nspaces: 3+1", "Equiv.\tspaces: 3+2"), List("Equiv.\u000bspaces: 3+0", "Equiv.\nspaces: 3+1", "Equiv.\tspaces: 3+2", "Equiv.\u000cspaces: 3-1", "Equiv.\rspaces: 3-2", "Equiv. spaces: 3-3")),
    ("3 Case Independent sort", List("cASE INDEPENENT: 3-2", "caSE INDEPENENT: 3-1", "casE INDEPENENT: 3+0", "case INDEPENENT: 3+1"), List("casE INDEPENENT: 3+0", "case INDEPENENT: 3+1", "caSE INDEPENENT: 3-1", "cASE INDEPENENT: 3-2")),
    ("4 Numeric fields as numerics", List("foo100bar99baz0.txt", "foo100bar10baz0.txt", "foo1000bar99baz10.txt", "foo1000bar99baz9.txt"), List("foo100bar10baz0.txt", "foo100bar99baz0.txt", "foo1000bar99baz9.txt", "foo1000bar99baz10.txt")),
    ("5 Title sorts", List("The Wind in the Willows", "The 40th step more", "The 39 steps", "Wanda"), List("The 39 steps", "The 40th step more", "Wanda", "The Wind in the Willows")),
    ("6 Equivalent accented characters (and case)", List("Equiv. \u00fd accents: 2-2", "Equiv. \u00dd accents: 2-1", "Equiv. y accents: 2+0", "Equiv. Y accents: 2+1"), List("Equiv. y accents: 2+0", "Equiv. Y accents: 2+1", "Equiv. \u00dd accents: 2-1", "Equiv. \u00fd accents: 2-2")),
    ("7 Separated ligatures", List("\u0132 ligatured ij", "no ligature"), List("\u0132 ligatured ij", "no ligature")),
    ("8 Character replacements", List("Start with an \u0292: 2-2", "Start with an \u017f: 2-1", "Start with an \u00df: 2+0", "Start with an s: 2+1"), List("Start with an s: 2+1", "Start with an \u017f: 2-1", "Start with an \u0292: 2-2", "Start with an \u00df: 2+0"))
  )

  val width = tests.flatMap(_._2).map(_.length).max
  assert(tests.forall{case (title, input, expected) =>
    val result = input.sortBy(natural)
    val okay = result == expected
    val label = if (okay) "pass" else "fail"
    println(s"$label: $title".toUpperCase)
    input.zip(result).foreach{case (a, b) => println(s"  ${a.padTo(width, ' ')}  |  ${b.padTo(width, ' ')}")}
    okay
  })
}


use MIDI::Simple;

# setup, 1 quarter note is 0.5 seconds (500,000 microseconds)
set_tempo 500_000;

# C-major scale
n 60; n 62; n 64; n 65; n 67; n 69; n 71; n 72;

write_score 'scale.mid';


--
-- demo\rosetta\Musical_scale.exw
--
with javascript_semantics
include pGUI.e
include builtins\beep.e

constant freq = {261.63,293.66,329.63,349.23,392,440,493.88,523.25},
    durations = repeat(500,length(freq)-1) & 1000

function button_cb(Ihandle /*playbtn*/)
    beep(freq,durations,0.5)
    return IUP_DEFAULT
end function

IupOpen()
Ihandle label = IupLabel("Please don't shoot the piano player, he's doing the best that he can!"),
        playbtn = IupButton("Play",Icallback("button_cb"),"PADDING=30x0"),
        hbox = IupHbox({IupFill(),playbtn,IupFill()},"MARGIN=0x20"),
        vbox = IupVbox({label,hbox}, "MARGIN=10x5, GAP=5"),
        dlg = IupDialog(vbox,`TITLE="Musical Scale"`)
IupShow(dlg)
if platform()!=JS then
    IupMainLoop()
    IupClose()
end if


(import (scheme base)
        (scheme char)
        (scheme write)
        (only (srfi 1) drop take-while)
        (only (srfi 13) string-drop string-join string-prefix-ci? string-tokenize)
        (srfi 132))

;; Natural sort function
(define (natural-sort lst)
  ; <1><2> ignores leading, trailing and multiple adjacent spaces
  ;        by tokenizing on whitespace (all whitespace characters),
  ;        and joining with a single space
  (define (ignore-spaces str)
    (string-join (string-tokenize str) " "))
  ; <5> Remove articles from string
  (define (drop-articles str)
    (define (do-drop articles str)
      (cond ((null? articles)
             str)
            ((string-prefix-ci? (car articles) str)
             (string-drop str (string-length (car articles))))
            (else
              (do-drop (cdr articles) str))))
    (do-drop '("a " "an " "the ") str))
  ; <4> split string into number/non-number groups
  (define (group-digits str)
    (let loop ((chars (string->list str))
               (doing-num? (char-numeric? (string-ref str 0)))
               (groups '()))
      (if (null? chars)
        (map (lambda (s) ; convert numbers to actual numbers
               (if (char-numeric? (string-ref s 0))
                 (string->number s)
                 s))
             (map list->string groups)) ; leave groups in reverse, as right-most significant
        (let ((next-group (take-while (if doing-num?
                                        char-numeric?
                                        (lambda (c) (not (char-numeric? c))))
                                      chars)))
          (loop (drop chars (length next-group))
                (not doing-num?)
                (cons next-group groups))))))
  ;
  (list-sort
    (lambda (a b) ; implements the numeric fields comparison <4>
      (let loop ((lft (group-digits (drop-articles (ignore-spaces a))))
                 (rgt (group-digits (drop-articles (ignore-spaces b)))))
        (cond ((null? lft) ; a is shorter
               #t)
              ((null? rgt) ; b is shorter
               #f)
              ((equal? (car lft) (car rgt)) ; if equal, look at next pair
               (loop (cdr lft) (cdr rgt)))
              ((and (number? (car lft)) ; compare as numbers
                    (number? (car rgt)))
               (< (car lft) (car rgt)))
              ((and (string? (car lft)) ; compare as strings
                    (string? (car rgt)))
               (string-ci<? (car lft) (car rgt))) ; <3> ignoring case
              ((and (number? (car lft)) ; strings before numbers
                    (string? (car rgt)))
               #f)
              ((and (string? (car lft)) ; strings before numbers
                    (number? (car rgt)))
               #t))))
    lst))

;; run string examples
(define (display-list title lst)
  (display title) (newline)
  (display "[\n") (for-each (lambda (i) (display i)(newline)) lst) (display "]\n"))

(for-each
  (lambda (title example)
    (display title) (newline)
    (display-list "Text strings:" example)
    (display-list "Normally sorted:" (list-sort string<? example))
    (display-list "Naturally sorted:" (natural-sort example))
    (newline))
  '("# Ignoring leading spaces" "# Ignoring multiple adjacent spaces (m.a.s.)"
    "# Equivalent whitespace characters" "# Case Independent sort"
    "# Numeric fields as numerics" "# Numeric fields as numerics - shows sorting from right"
    "# Title sorts")
  '(("ignore leading spaces: 2-2" " ignore leading spaces: 2-1" "  ignore leading spaces: 2+0" "   ignore leading spaces: 2+1")
    ("ignore m.a.s spaces: 2-2" "ignore m.a.s  spaces: 2-1" "ignore m.a.s   spaces: 2+0" "ignore m.a.s    spaces: 2+1")
    ("Equiv. spaces: 3-3" "Equiv.\rspaces: 3-2" "Equiv.\x0c;spaces: 3-1" "Equiv.\x0b;spaces: 3+0" "Equiv.\nspaces: 3+1" "Equiv.\tspaces: 3+2")
    ("cASE INDEPENDENT: 3-2" "caSE INDEPENDENT: 3-1" "casE INDEPENDENT: 3+0" "case INDEPENDENT: 3+1")
    ("foo100bar99baz0.txt" "foo100bar10baz0.txt" "foo1000bar99baz10.txt" "foo1000bar99baz9.txt")
    ("foo1bar99baz4.txt" "foo2bar99baz3.txt" "foo4bar99baz1.txt" "foo3bar99baz2.txt")
    ("The Wind in the Willows" "The 40th step more" "The 39 steps" "Wanda")))


#lang racket
(require ffi/unsafe ffi/unsafe/define)
(define-ffi-definer defmm (ffi-lib "Winmm"))
(defmm midiOutOpen (_fun [h : (_ptr o _int32)] [_int = -1] [_pointer = #f]
                         [_pointer = #f] [_int32 = 0] -> _void -> h))
(defmm midiOutShortMsg (_fun _int32 _int32 -> _void))
(define M (midiOutOpen))
(define (midi x y z) (midiOutShortMsg M (+ x (* 256 y) (* 65536 z))))

(for ([i '(60 62 64 65 67 69 71 72)]) (midi #x90 i 127) (sleep 0.5))
(sleep 2)