//*REXX program displays the  ordered partitions  as:   orderedPartitions(i, j, k, ···). */
call orderedPartitions  2,0,2                    /*Note:      2,,2      will also work. */
call orderedPartitions  1,1,1
call orderedPartitions  1,2,0,1                  /*Note:      1,2,,1    will also work. */
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
orderedPartitions: procedure;  #=arg();   bot.=;   top.=;   low=;    high=;    d=123456789
t=0                                              /*T:   is the sum of all the arguments.*/
          do i=1  for #;       t=t + arg(i)      /*sum all the highest numbers in parts.*/
          end   /*i*/                            /* [↑]  may have an omitted argument.  */
hdr= ' partitions for: '                         /*define the start of the header text. */
  do j=1  for #;               _= arg(j)         /*  _:  is the    Jth   argument.      */
  len.j=max(1, _)                                /*LEN:  length of args.  «0 is special»*/
  bot.j=left(d, _);         if _==0 then bot.j=0 /*define the  bottom  number for range.*/
  top.j=right(left(d,t),_); if _==0 then top.j=0 /*  "     "     top      "    "    "   */
  @.j=left(d, t);           if _==0 then   @.j=0 /*define the digits used for  VERIFY.  */
  hdr=hdr _                                      /*build (by appending)  display header.*/
  low=low || bot.j;         high=high || top.j   /*the low and high numbers for DO below*/
  end   /*j*/
                                                 /* [↓]  same as:   okD=left('0'd, t+1) */
              /*define the legal digits to be used.  */
okD=left(0 || d,  t + 1)                         /*define the legal digits to be used.  */
say;   hdr=center(hdr" ",  60, '═');     say hdr /*display centered title for the output*/
say                                              /*show a blank line  (as a separator). */
    do g=low  to high                            /* [↑]  generate the ordered partitions*/
    if verify(g, okD) \==0  then iterate         /*filter out unwanted partitions (digs)*/
    p=1                                          /*P:  is the position of a decimal dig.*/
    $=                                           /*$:  will be the transformed numbers. */
       do k=1  for #;   _=substr(g, p, len.k)    /*verify the partitions numbers.       */
       if verify(_, @.k) \==0  then iterate g    /*is the decimal digit not valid ?     */
       !=                                        /* [↓]  validate the decimal number.   */
       if @.k\==0  then do j=1  for length(_);     z=substr(_, j, 1)        /*get a dig.*/
                        if pos(z, $)\==0               then iterate g       /*previous ?*/
                        !=!','z                                             /*add comma.*/
                        if j==1                        then iterate         /*is firstt?*/
                        if z<=substr(_, j-1, 1)        then iterate g       /*ordered  ?*/
                        if pos(z, _, 1 +pos(z, _))\==0 then iterate g       /*duplicate?*/
                        end   /*j*/
       p=p + len.k                               /*point to the next decimal digit (num)*/
       $=$ '  {'strip(translate(!, ,0), ,",")'}' /*dress number up by suppessing LZ ··· */
       end   /*k*/
    say center($, length(hdr) )                  /*display numbers in ordered partition.*/
    end      /*g*/
return


define(`palindrorev',`ifelse(`$1',invert(`$1'),`yes',`no')')dnl
palindrorev(`ingirumimusnocteetconsumimurigni')
palindrorev(`this is not palindrome')


with(StringTools):

IsPalindrome("ingirumimusnocteetconsumimurigni");

IsPalindrome("In girum imus nocte et consumimur igni");

IsPalindrome(LowerCase(DeleteSpace("In girum imus nocte et consumimur igni")));


def partition(mask)
  return [[]] if mask.empty?
  [*1..mask.inject(:+)].permutation.map {|perm|
    mask.map {|num_elts| perm.shift(num_elts).sort }
  }.uniq
end


use itertools::Itertools;

type NArray = Vec<Vec<Vec<usize>>>;

fn generate_partitions(args: &[usize]) -> NArray {
    // calculate the sum of all partitions
    let max = args.iter().sum();

    // generate combinations with the given lengths
    // for each partition
    let c = args.iter().fold(vec![], |mut acc, arg| {
        acc.push((1..=max).combinations(*arg).collect::<Vec<_>>());
        acc
    });

    // create a cartesian product of all individual combinations
    // filter/keep only where all the elements are there and exactly once
    c.iter()
        .map(|i| i.iter().cloned())
        .multi_cartesian_product()
        .unique()
        .filter(|x| x.iter().cloned().flatten().unique().count() == max)
        .collect::<Vec<_>>()
}

#[allow(clippy::clippy::ptr_arg)]
fn print_partitions(result: &NArray) {
    println!("Partitions:");
    for partition in result {
        println!("{:?}", partition);
    }
}
fn main() {
    print_partitions(generate_partitions(&[2, 0, 2]).as_ref());
    print_partitions(generate_partitions(&[1, 1, 1]).as_ref());
    print_partitions(generate_partitions(&[2, 3]).as_ref());
    print_partitions(generate_partitions(&[0]).as_ref());
}


func part(_,    {.is_empty}) { [[]] }
func partitions({.is_empty}) { [[]] }

func part(s, args) {
  gather {
    s.combinations(args[0], { |*c|
      part(s - c, args.ft(1)).each{|r| take([c] + r) }
    })
  }
}

func partitions(args) {
  part(@(1..args.sum), args)
}

[[],[0,0,0],[1,1,1],[2,0,2]].each { |test_case|
  say "partitions #{test_case}:"
  partitions(test_case).each{|part| say part }
  print "\n"
}


function trueFalse = isPalindrome(string)

    trueFalse = all(string == fliplr(string)); %See if flipping the string produces the original string

    if not(trueFalse) %If not a palindrome
        string = lower(string); %Lower case everything
        trueFalse = all(string == fliplr(string)); %Test again
    end

    if not(trueFalse) %If still not a palindrome
        string(isspace(string)) = []; %Strip all space characters out
        trueFalse = all(string == fliplr(string)); %Test one last time
    end

end


palindromep(s) := block([t], t: sremove(" ", sdowncase(s)), sequal(t, sreverse(t)))$

palindromep("Sator arepo tenet opera rotas");  /* true */


package require Tcl 8.5
package require struct::set

# Selects all k-sized combinations from a list.
# "Borrowed" from elsewhere on RC
proc selectCombinationsFrom {k l} {
    if {$k == 0} {return {}} elseif {$k == [llength $l]} {return [list $l]}
    set all {}
    set n [expr {[llength $l] - [incr k -1]}]
    for {set i 0} {$i < $n} {} {
        set first [lindex $l $i]
	incr i
        if {$k == 0} {
            lappend all $first
	} else {
	    foreach s [selectCombinationsFrom $k [lrange $l $i end]] {
		lappend all [list $first {*}$s]
	    }
        }
    }
    return $all
}

# Construct the partitioning of a given list
proc buildPartitions {lst n args} {
    # Base case when we have no further partitions to process
    if {[llength $args] == 0} {
	return [list [list $lst]]
    }
    set result {}
    set c [selectCombinationsFrom $n $lst]
    if {[llength $c] == 0} {set c [list $c]}
    foreach comb $c {
	# Sort necessary for "nice" order
	set rest [lsort -integer [struct::set difference $lst $comb]]
	foreach p [buildPartitions $rest {*}$args] {
	    lappend result [list $comb {*}$p]
	}
    }
    return $result
}

# Wrapper that assembles the initial list and calls the partitioner
proc partitions args {
    set sum [tcl::mathop::+ {*}$args]
    set startingSet {}
    for {set i 1} {$i <= $sum} {incr i} {
	lappend startingSet $i
    }

    return [buildPartitions $startingSet {*}$args]
}


fn isPalindrome s =
(
    local reversed = ""
    for i in s.count to 1 by -1 do reversed += s[i]
    return reversed == s
)


(dup reverse ==) :palindrome?
(dup "" split reverse "" join ==) :str-palindrome?

"apple" str-palindrome? puts
"racecar" str-palindrome? puts
(a b c) palindrome? puts
(a b b a) palindrome? puts


isPalindrome = function(s)
    // convert to lowercase, and strip non-letters
    stripped = ""
    for c in s.lower
    	if c >= "a" and c <= "z" then stripped = stripped + c
    end for

    // check palindromity
    mid = floor(stripped.len/2)
    for i in range(0, mid)
    	if stripped[i] != stripped[-i - 1] then return false
    end for
    return true
end function

testStr = "Madam, I'm Adam"
answer = [testStr, "is"]
if not isPalindrome(testStr) then answer.push "NOT"
answer.push "a palindrome"
print answer.join


#import std
#import nat

opart =

-+
  ~&art^?\~&alNCNC ^|JalSPfarSPMplrDSL/~& ^DrlPrrPlXXS/~&rt ^DrlrjXS/~&l [email protected],
  ^\~& nrange/1+ sum:-0+-


import "os" for Process

var genPart // recursive so predeclare
genPart = Fn.new { |n, res, pos|
    if (pos == res.count) {
        var x = List.filled(n.count, null)
        for (i in 0...x.count) x[i] = []
        var i = 0
        for (c in res) {
            x[c].add(i+1)
            i = i + 1
        }
        System.print(x)
        return
    }
    for (i in 0...n.count) {
        if (n[i] != 0) {
            n[i] = n[i] - 1
            res[pos] = i
            genPart.call(n, res, pos+1)
            n[i] = n[i] + 1
        }
    }
}

var orderedPart = Fn.new { |nParts|
    System.print("Ordered %(nParts)")
    var sum = 0
    for (c in nParts) sum = sum + c
    genPart.call(nParts, List.filled(sum, 0), 0)
}

var args = Process.arguments
if (args.count == 0) {
    orderedPart.call([2, 0, 2])
    return
}
var n = List.filled(args.count, 0)
var i = 0
for (a in args) {
    n[i] = Num.fromString(a)
    if (n[i] < 0) {
        System.print("negative partition size not meaningful")
        return
    }
    i = i + 1
}
orderedPart.call(n)


def reverse(s:string)
    StringBuilder.new(s).reverse.toString()
end

def palindrome?(s:string)
    s.equals(reverse(s))
end

puts palindrome?("anna")        # ==> true
puts palindrome?("Erik")        # ==> false
puts palindrome?("palindroom-moordnilap") # ==> true
puts nil                        # ==> null


fun to_locase s = implode ` map (c_downcase) ` explode s

fun only_alpha s = implode ` filter (fn x = c_alphabetic x) ` explode s

fun is_palin
	( h1 :: t1, h2 :: t2, n = 0 ) 		       = true
|	( h1 :: t1, h2 :: t2, n ) where ( h1 eql h2 )  = is_palin( t1, t2, n - 1)
|	( h1 :: t1, h2 :: t2, n )                      = false
|       (str s) =
		let
			val es = explode ` to_locase ` only_alpha s;
			val res = rev es;
			val k = (len es) div 2
		in
			is_palin (es, res, k)
		end

fun test_is_palin s =
	(print "\""; print s; print "\" is a palindrome: "; print ` is_palin s; println "")

fun test (f, arg, res, ok, notok) = if (f arg eql res) then ("'" @ arg @ "' " @ ok) else ("'" @ arg @ "' " @ notok)

;

println ` test (is_palin, "In girum imus nocte, et consumimur igni", true, "is a palindrome", "is NOT a palindrome");
println ` test (is_palin, "Madam, I'm Adam.", true, "is a palindrome", "is NOT a palindrome");
println ` test (is_palin, "salàlas", true, "is a palindrome", "is NOT a palindrome");
println ` test (is_palin, "radar", true, "is a palindrome", "is NOT a palindrome");
println ` test (is_palin, "Lagerregal", true, "is a palindrome", "is NOT a palindrome");
println ` test (is_palin, "Ein Neger mit Gazelle zagt im Regen nie.", true, "is a palindrome", "is NOT a palindrome");
println ` test (is_palin, "something wrong", true, "is a palindrome", "is NOT a palindrome");


fcn partitions(args){
   args=vm.arglist;
   s:=(1).pump(args.sum(0),List);  // (1,2,3,...)
   fcn(s,args,p){
      if(not args) return(T(T));
      res:=List();
      foreach c in (Utils.Helpers.pickNFrom(args[0],s)){
	 s0:=s.copy().removeEach(c);
	 foreach r in (self.fcn(s0,args[1,*])){ res.append(T(c).extend(r)) }
      }
      res
   }(s,args)
}


argc     IS $0
argv     IS $1

         LOC Data_Segment
DataSeg  GREG @

          LOC @+1000
ItsPalStr IS @-Data_Segment
          BYTE "It's palindrome",10,0
          LOC @+(8-@)&7
NoPalStr  IS  @-Data_Segment
          BYTE "It is not palindrome",10,0

         LOC #100
         GREG @
% input: $255 points to where the string to be checked is
% returns $255 0 if not palindrome, not zero otherwise
% trashs: $0,$1,$2,$3
% return address $4
DetectPalindrome LOC @
         ADDU $1,$255,0      % $1 = $255
2H       LDB  $0,$1,0        % get byte at $1
         BZ   $0,1F          % if zero, end (length)
         INCL $1,1           % $1++
         JMP  2B             % loop
1H       SUBU $1,$1,1        % ptr last char of string
         ADDU $0,DataSeg,0   % $0 to data seg.
3H       CMP  $3,$1,$255     % is $0 == $255?
         BZ   $3,4F          % then jump
         LDB  $3,$1,0        % otherwise get the byte
         STB  $3,$0,0        % and copy it
         INCL $0,1           % $0++
         SUB  $1,$1,1        % $1--
         JMP  3B
4H       LDB  $3,$1,0
         STB  $3,$0,0        % copy the last byte
% now let us compare reversed string and straight string
         XOR  $0,$0,$0       % index
         ADDU $1,DataSeg,0
6H       LDB  $2,$1,$0       % pick char from rev str
         LDB  $3,$255,$0     % pick char from straight str
         BZ   $3,PaliOk      % finished as palindrome
         CMP  $2,$2,$3       % == ?
         BNZ  $2,5F          % if not, exit
         INCL $0,1           % $0++
         JMP  6B
5H       XOR  $255,$255,$255
         GO   $4,$4,0        % return false
PaliOk   NEG  $255,0,1
         GO   $4,$4,0        % return true

% The Main for testing the function
% run from the command line
% $ mmix ./palindrome.mmo ingirumimusnocteetconsumimurigni
Main     CMP  argc,argc,2    % argc > 2?
         BN   argc,3F        % no -> not enough arg
         ADDU $1,$1,8        % argv+1
         LDOU $255,$1,0      % argv[1]
         GO   $4,DetectPalindrome
         BZ   $255,2F        % if not palindrome, jmp
         SETL $0,ItsPalStr   % pal string
         ADDU $255,DataSeg,$0
         JMP  1F
2H       SETL $0,NoPalStr    % no pal string
         ADDU $255,DataSeg,$0
1H       TRAP 0,Fputs,StdOut % print
3H       XOR  $255,$255,$255
         TRAP 0,Halt,0       % exit(0)


MODULE Palindrome;
FROM FormatString IMPORT FormatString;
FROM Terminal IMPORT WriteString,ReadChar;

PROCEDURE IsPalindrome(str : ARRAY OF CHAR) : BOOLEAN;
VAR i,m : INTEGER;
VAR buf : ARRAY[0..63] OF CHAR;
BEGIN
    i := 0;
    m := HIGH(str) - 1;
    WHILE i<m DO
        IF str[i] # str[m-i] THEN
            RETURN FALSE
        END;
        INC(i)
    END;
    RETURN TRUE
END IsPalindrome;

PROCEDURE Print(str : ARRAY OF CHAR);
VAR buf : ARRAY[0..63] OF CHAR;
BEGIN
    FormatString("%s: %b\n", buf, str, IsPalindrome(str));
    WriteString(buf)
END Print;

BEGIN
    Print("");
    Print("z");
    Print("aha");
    Print("sees");
    Print("oofoe");
    Print("deified");
    Print("Deified");
    Print("amanaplanacanalpanama");
    Print("ingirumimusnocteetconsumimurigni");

    ReadChar
END Palindrome.


MODULE Palindrome;

IMPORT Text;

PROCEDURE isPalindrome(string: TEXT): BOOLEAN =
  VAR len := Text.Length(string);
  BEGIN
    FOR i := 0 TO len DIV 2 - 1 DO
      IF Text.GetChar(string, i) # Text.GetChar(string, (len - i - 1)) THEN
        RETURN FALSE;
      END;
    END;
    RETURN TRUE;
  END isPalindrome;
END Palindrome.


def is_palindrome(s)
        temp = ""
        for char in s
                if "abcdefghikjklmnopqrstuvwxyz" .contains. lower(char)
                        temp += lower(char)
                end
        end

        return list(temp) = list(temp).reverse()
end


using System;
using System.Console;
using Nemerle.Utility.NString; //contains methods Explode() and Implode() which convert string -> list[char] and back

module Palindrome
{
    IsPalindrome( text : string) : bool
    {
        Implode(Explode(text).Reverse()) == text;
    }

    Main() : void
    {
        WriteLine("radar is a palindrome: {0}", IsPalindrome("radar"));
    }
}


y='In girum imus nocte et consumimur igni'

-- translation: We walk around in the night and
-- we are burnt by the fire (of love)
say
say 'string = 'y
say

pal=isPal(y)

if pal==0 then say "The string isn't palindromic."
          else say 'The string is palindromic.'

method isPal(x) static
  x=x.upper().space(0)          /* removes all blanks (spaces)          */
                                /*   and translate to uppercase.        */
  return x==x.reverse()         /* returns  1  if exactly equal         */


(define (palindrome? s)
    (setq r s)
    (reverse r) ; Reverse is destructive.
    (= s r))

;; Make ‘reverse’ non-destructive and avoid a global variable
(define (palindrome? s)
    (= s (reverse (copy s))))


import unicode

func isPalindrome(rseq: seq[Rune]): bool =
  ## Return true if a sequence of runes is a palindrome.
  for i in 1..(rseq.len shr 1):
    if rseq[i - 1] != rseq[^i]:
      return false
  result = true

func isPalindrome(str: string; exact = true): bool {.inline.} =
  ## Return true if a UTF-8 string is a palindrome.
  ## If "exact" is false, ignore white spaces and ignore case.

  if exact:
    result = str.toRunes.isPalindrome()
  else:
    var rseq: seq[Rune]
    for rune in str.runes:
      if not rune.isWhiteSpace:
        rseq.add rune.toLower
    result = rseq.isPalindrome()

when isMainModule:

  proc check(s: string) =
    var exact, inexact: bool
    exact = s.isPalindrome()
    if not exact:
      inexact = s.isPalindrome(exact = false)
    let txt = if exact: " is an exact palindrome."
              elif inexact: " is an inexact palindrome."
              else: " is not a palindrome."
    echo '"', s, '"', txt

check "rotor"
check "été"
check "αννα"
check "salÃ las"
check "In girum imus nocte et consumimur igni"
check "Esope reste ici et se repose"
check "This is a palindrom"


bundle Default {
  class Test {
    function : Main(args : String[]) ~ Nil {
      IsPalindrome("aasa")->PrintLine();
      IsPalindrome("acbca")->PrintLine();
      IsPalindrome("xx")->PrintLine();
    }

    function : native : IsPalindrome(s : String) ~ Bool {
      l := s->Size();
      for(i := 0; i < l / 2; i += 1;) {
        if(s->Get(i) <> s->Get(l - i - 1)) {
          return false;
        };
      };

      return true;
    }
  }
}


let is_palindrome s =
    let l = String.length s in
    let rec comp n =
        n = 0 || (s.[l-n] = s.[n-1] && comp (n-1)) in
    comp (l / 2)


function v = palindro_r(s)
  if ( length(s) == 1 )
    v = true;
    return;
  elseif ( length(s) == 2 )
    v = s(1) == s(2);
    return;
  endif
  if ( s(1) == s(length(s)) )
    v = palindro_r(s(2:length(s)-1));
  else
    v = false;
  endif
endfunction


String method: isPalindrome  self reverse self == ;


; simple case - only lowercase letters
(define (palindrome? str)
   (let ((l (string->runes str)))
      (equal? l (reverse l))))

(print (palindrome? "ingirumimusnocteetconsumimurigni"))
; ==> #true
(print (palindrome? "thisisnotapalindrome"))
; ==> #false

; complex case - with ignoring letter case and punctuation
(define (alpha? x)
   (<= #\a x #\z))
(define (lowercase x)
   (if (<= #\A x #\Z)
      (- x (- #\A #\a))
      x))

(define (palindrome? str)
   (let ((l (filter alpha? (map lowercase (string->runes str)))))
      (equal? l (reverse l))))

(print (palindrome? "A man, a plan, a cat, a ham, a yak, a yam, a hat, a canal-Panama!"))
; ==> #true
(print (palindrome? "This is not a palindrome"))
; ==> #false


fun {IsPalindrome S}
  {Reverse S} == S
end


program Palindro;

{ RECURSIVE }
function is_palindro_r(s : String) : Boolean;
begin
   if length(s) <= 1 then
      is_palindro_r := true
   else begin
      if s[1] = s[length(s)] then
	 is_palindro_r := is_palindro_r(copy(s, 2, length(s)-2))
      else
	 is_palindro_r := false
   end
end; { is_palindro_r }

{ NON RECURSIVE; see [[Reversing a string]] for "reverse" }
function is_palindro(s : String) : Boolean;
begin
   if s = reverse(s) then
      is_palindro := true
   else
      is_palindro := false
end;


# Palindrome.pm
package Palindrome;

use strict;
use warnings;

use Exporter 'import';
our @EXPORT = qw(palindrome palindrome_c palindrome_r palindrome_e);

sub palindrome
{
    my $s = (@_ ? shift : $_);
    return $s eq reverse $s;
}

sub palindrome_c
{
    my $s = (@_ ? shift : $_);
    for my $i (0 .. length($s) >> 1)
    {
        return 0 unless substr($s, $i, 1) eq substr($s, -1 - $i, 1);
    }
    return 1;
}

sub palindrome_r
{
    my $s = (@_ ? shift : $_);
    if (length $s <= 1) { return 1; }
    elsif (substr($s, 0, 1) ne substr($s, -1, 1)) { return 0; }
    else { return palindrome_r(substr($s, 1, -1)); }
}

sub palindrome_e
{
    (@_ ? shift : $_) =~ /^(.?|(.)(?1)\2)$/ + 0
}


function is_palindrome(sequence s)
    return s==reverse(s)
end function

?is_palindrome("rotator") -- prints 1
?is_palindrome("tractor") -- prints 0

constant punctuation = " `[email protected]#$%^&*()-=_+[]{}\\|;:',.<>/?",
         nulls = repeat("",length(punctuation))

function extra_credit(sequence s)
    s = utf8_to_utf32(lower(substitute_all(s,punctuation,nulls)))
    return s==reverse(s)
end function

-- these all print 1 (true)
?extra_credit("Madam, I'm Adam.")
?extra_credit("A man, a plan, a canal: Panama!")
?extra_credit("In girum imus nocte et consumimur igni")
?extra_credit("人人為我,我為人人")
?extra_credit("Я иду с мечем, судия")
?extra_credit("아들딸들아")
?extra_credit("가련하시다 사장집 아들딸들아 집장사 다시 하련가")
?extra_credit("tregða, gón, reiði - er nóg að gert")


<?php
function is_palindrome($string) {
  return $string == strrev($string);
}
?>


go =>
   Tests = ["In girum imus nocte et consumimur igni",
            "this is a non palindrome string",
            "anna ABcdcBA anna",
            "anna ABcdcBA annax",
            "A man, a plan, a canoe, pasta, heros, rajahs" ++
            "a coloratura, maps, snipe, percale, macaroni, " ++
            "a gag, a banana bag, a tan, a tag, " ++
            "a banana bag again (or a camel), a crepe, pins, " ++
            "Spam, a rut, a Rolo, cash, a jar, sore hats, " ++
            "a peon, a canal - Panama!",
            10,
            111111,
            12221,
            9384212,
            10.01
           ],

   foreach(Test in Tests)
     if is_palindrome(Test) then
        println([Test, "exact palindrome"])
     elseif is_palindrome_inexact(Test) then
        println([Test, "inexact palindrome"])
     else
        println([Test, "no"])
     end
   end,
   nl.

% Detect palindromes for strings (and numbers).
is_palindrome(N), number(N) => is_palindrome(N.to_string()).
is_palindrome(S) => S == S.reverse().

% Detect inexact palindromes.
is_palindrome_inexact(N), number(N) => is_palindrome_inexact(N.to_string()).
is_palindrome_inexact(S) =>
    is_palindrome(strip(S)).

% convert to lowercase and
% skips punctuation and white space.
strip(S) = [C : C in S.to_lowercase(),
            not C.membchk("!?,.;-_ \t\n()[]{}")].


(de palindrome? (S)
   (= (setq S (chop S)) (reverse S)) )


int main(){
   if(pal("rotator")){
      write("palindrome!\n");
   }
   if(!pal("asdf")){
      write("asdf isn't a palindrome.\n");
   }
}

int pal(string input){
   if( reverse(input) == input ){
      return 1;
   } else {
      return 0;
   }
}


100H:

/* CHECK EXACT PALINDROME ASSUMING $-TERMINATED STRING */
PALINDROME: PROCEDURE(PTR) BYTE;
    DECLARE (PTR, FRONT, BACK) ADDRESS, STR BASED PTR BYTE;

    /* FIND END */
    FRONT, BACK = 0;
    DO WHILE STR(BACK) <> '$';
        BACK = BACK + 1;
    END;
    BACK = BACK - 1;

    /* CHECK MATCH */
    DO WHILE (FRONT < BACK) AND (STR(FRONT) = STR(BACK));
        FRONT = FRONT + 1;
        BACK = BACK - 1;
    END;

    RETURN FRONT >= BACK;
END PALINDROME;

/* CHECK INEXACT PALINDROME: FILTER OUT NON-LETTERS AND NUMBERS */
INEXACT$PALINDROME: PROCEDURE(PTR) BYTE;
    /* 256 BYTES OUGHT TO BE ENOUGH FOR EVERYONE */
    DECLARE (PTR, OPTR) ADDRESS;
    DECLARE FILTER (256) BYTE;
    DECLARE (IN BASED PTR, OUT BASED OPTR) BYTE;
    OPTR = .FILTER;

    DO WHILE IN <> '$';
        OUT = IN OR 32;
        /* LOWERCASE CHARACTERS ARE NOT IN THE PL/M CHARSET,
           BUT WE CAN JUST WRITE THE ASCII VALUES AS NUMBERS */
        IF (OUT >= '0' AND OUT <= '9')
        OR (OUT >= 97  AND OUT <= 122) THEN
            OPTR = OPTR + 1;
        PTR = PTR + 1;
    END;
    OUT = '$';

    RETURN PALINDROME(.FILTER);
END INEXACT$PALINDROME;

/* CP/M BDOS CALLS */
BDOS: PROCEDURE(FUNC, ARG);
    DECLARE FUNC BYTE, ARG ADDRESS;
    GO TO 5;
END BDOS;

PRINT: PROCEDURE(STRING);
    DECLARE STRING ADDRESS;
    CALL BDOS(9, STRING);
END PRINT;

/* TEST SOME STRINGS */
DECLARE STRINGS (8) ADDRESS;
STRINGS(0) = .'ROTOR$';
STRINGS(1) = .'RACECAR$';
STRINGS(2) = .'LEVEL$';
STRINGS(3) = .'REDDER$';
STRINGS(4) = .'RACECAR$';
STRINGS(5) = .'A MAN, A PLAN, A CANAL: PANAMA$';
STRINGS(6) = .'EGAD, A BASE TONE DENOTES A BAD AGE.$';
STRINGS(7) = .'ROSETTA$';

DECLARE N BYTE;
DO N = 0 TO LAST(STRINGS);
    CALL PRINT(STRINGS(N));
    CALL PRINT(.': $');
    IF PALINDROME(STRINGS(N)) THEN
        CALL PRINT(.'EXACT$');
    ELSE IF INEXACT$PALINDROME(STRINGS(N)) THEN
        CALL PRINT(.'INEXACT$');
    ELSE
        CALL PRINT(.'NOT A PALINDROME$');
    CALL PRINT(.(13,10,'$'));
END;

CALL BDOS(0,0);
EOF


To decide if a string is palindromic:
Slap a substring on the string.
Loop.
If the substring's first is greater than the substring's last, say yes.
If the substring's first's target is not the substring's last's target, say no.
Add 1 to the substring's first.
Subtract 1 from the substring's last.
Repeat.


isPalindrome(chars) =
  chars == reverse(chars)


# The readable recursive version
palindrome_i = (s, b, e):
  if (e <= b): true.
  elsif (s ord(b) != s ord(e)): false.
  else: palindrome_i(s, b+1, e-1).
.

palindrome = (s):
  palindrome_i(s, 0, s length - 1).

palindrome(argv(1))


FUNCTION isPalindrome (what AS STRING) AS LONG
    DIM whatcopy AS STRING, chk AS STRING, tmp AS STRING * 1, L0 AS LONG

    FOR L0 = 1 TO LEN(what)
        tmp = UCASE$(MID$(what, L0, 1))
        SELECT CASE tmp
            CASE "A" TO "Z"
                whatcopy = whatcopy & tmp
                chk = tmp & chk
            CASE "0" TO "9"
                MSGBOX "Numbers are cheating! (""" & what & """)"
                FUNCTION = 0
                EXIT FUNCTION
        END SELECT
    NEXT

    FUNCTION = ISTRUE((whatcopy) = chk)
END FUNCTION

FUNCTION PBMAIN () AS LONG
    DATA "My dog has fleas", "Madam, I'm Adam.", "1 on 1", "In girum imus nocte et consumimur igni"
    DIM L1 AS LONG, w AS STRING
    FOR L1 = 1 TO DATACOUNT
        w = READ$(L1)
        IF ISTRUE(isPalindrome(w)) THEN
            MSGBOX $DQ & w & """ is a palindrome"
        ELSE
            MSGBOX $DQ & w & """ is not a palindrome"
        END IF
    NEXT
END FUNCTION


Function Test-Palindrome( [String] $Text ){
    $CharArray = $Text.ToCharArray()
    [Array]::Reverse($CharArray)
    $Text -eq [string]::join('', $CharArray)
}


void setup(){
	println(isPalindrome(InsertPalindromeHere));
}

boolean isPalindrome(string check){
	char[] letters = new char[check.length];
	string invert = " ";
	string modCheck = " " + check;
	for(int i = 0; i < letters.length; i++){
		letters[i] = check.charAt(i);
	}
	for(int i = letters.length-1; i >= 0; i--){
		invert = invert + letters[i];
	}

	if(invert == modCheck){
		return true;
	} else {
		return false;
	}
}


palindrome(Word) :- name(Word,List), reverse(List,List).


Procedure IsPalindrome(StringToTest.s)
  If StringToTest=ReverseString(StringToTest)
    ProcedureReturn 1
  Else
    ProcedureReturn 0
  EndIf
EndProcedure


def is_palindrome(s):
  return s == s[::-1]


  [ dup reverse = ]        is palindromic       ( [ --> b )

  [ [] swap witheach
      [ upper dup
        dup lower = iff
          drop else join ]
     palindromic ]         is inexactpalindrome ( $ --> b )


palindro <- function(p) {
  if ( nchar(p) == 1 ) {
    return(TRUE)
  } else if ( nchar(p) == 2 ) {
    return(substr(p,1,1) == substr(p,2,2))
  } else {
    if ( substr(p,1,1) == substr(p, nchar(p), nchar(p)) ) {
      return(palindro(substr(p, 2, nchar(p)-1)))
    } else {
      return(FALSE)
    }
  }
}


(define (palindromb str)
  (let* ([lst (string->list (string-downcase str))]
         [slst (remove* '(#\space) lst)])
    (string=? (list->string (reverse slst)) (list->string slst))))

;;example output

> (palindromb "able was i ere i saw elba")
#t
> (palindromb "waht the hey")
#f
> (palindromb "In girum imus nocte et consumimur igni")
#t
>


subset Palindrom of Str where {
    .flip eq $_ given .comb(/\w+/).join.lc
}

my @tests = q:to/END/.lines;
    A man, a plan, a canal: Panama.
    My dog has fleas
    Madam, I'm Adam.
    1 on 1
    In girum imus nocte et consumimur igni
    END

for @tests { say $_ ~~ Palindrom, "\t", $_ }


import String;

public bool palindrome(str text) =  toLowerCase(text) == reverse(text);


rebol [
    Title: "Palindrome Recognizer"
    URL: http://rosettacode.org/wiki/Palindrome
]

; In order to compete with all the one-liners, the operation is
; compressed: parens force left hand side to evaluate first, where I
; copy the phrase, then uppercase it and assign it to 'p'. Now the
; right hand side is evaluated: p is copied, then reversed in place;
; the comparison is made and implicitely returned.

palindrome?: func [
	phrase [string!] "Potentially palindromatic prose."
	/local p
][(p: uppercase copy phrase) = reverse copy p]

; Teeny Tiny Test Suite

assert: func [code][print [either do code ["  ok"]["FAIL"]  mold code]]

print "Simple palindromes, with an exception for variety:"
repeat phrase ["z" "aha" "sees" "oofoe" "Deified"][
	assert compose [palindrome? (phrase)]]

print [crlf "According to the problem statement, these should fail:"]
assert [palindrome? "A man, a plan, a canal, Panama."] ; Punctuation not ignored.
assert [palindrome? "In girum imus nocte et consumimur igni"] ; Spaces not removed.

; I know we're doing palindromes, not alliteration, but who could resist...?


:palindrome? (s-f) dup s:hash [ s:reverse s:hash ] dip eq? ;

'ingirumimusnocteetconsumimurigni palindrome? n:put


/*REXX pgm checks if phrase is palindromic; ignores the case of the letters.  */
parse arg y                            /*get (optional) phrase from the C.L.  */
if y=''  then y='In girum imus nocte et consumimur igni'    /*[↓] translation.*/
               /*We walk around in the night and we are burnt by the fire (of love).*/
say 'string = ' y
if isTpal(y)  then                   say 'The string is a true palindrome.'
              else if isPal(y)  then say 'The string is an inexact palindrome.'
                                else say "The string isn't palindromic."
exit                                   /*stick a fork in it,  we're all done. */
/*────────────────────────────────────────────────────────────────────────────*/
isTpal:  return reverse(arg(1))==arg(1)
isPal:   return isTpal(translate(space(x,0)))


aString = "radar"
bString = ""
for i=len(aString) to 1 step -1
    bString = bString + aString[i]
next
see aString
if aString = bString see " is a palindrome." + nl
else see " is not a palindrome" + nl ok


data "My dog has fleas", "Madam, I'm Adam.", "1 on 1", "In girum imus nocte et consumimur igni"

for i = 1 to 4
  read w$
  print w$;" is ";isPalindrome$(w$);" Palindrome"
next

FUNCTION isPalindrome$(str$)
for i = 1 to len(str$)
  a$ = upper$(mid$(str$,i,1))
   if (a$ >= "A" and a$ <= "Z") or (a$ >= "0" and a$ <= "9") then b$ = b$ + a$: c$ = a$ + c$
next i
if b$ <> c$ then isPalindrome$ = "not"


fn is_palindrome(string: &str) -> bool {
    let half_len = string.len() / 2;
    string
        .chars()
        .take(half_len)
        .eq(string.chars().rev().take(half_len))
}

macro_rules! test {
    ( $( $x:tt ),* ) => { $( println!("'{}': {}", $x, is_palindrome($x)); )* };
}

fn main() {
    test!(
        "",
        "a",
        "ada",
        "adad",
        "ingirumimusnocteetconsumimurigni",
        "人人為我,我為人人",
        "Я иду с мечем, судия",
        "아들딸들아",
        "The quick brown fox"
    );
}


The macro "palindro" has two parameters: string and ignorewhitespace.
  string is the expression to be checked.
  ignorewhitespace, (Y/N), determines whether or not to ignore blanks and punctuation.
This macro was written in SAS 9.2.  If you use a version before SAS 9.1.3,
the compress function options will not work.


def isPalindrome(s: String): Boolean = (s.size >= 2) && s == s.reverse


(define (palindrome? s)
  (let ((chars (string->list s)))
    (equal? chars (reverse chars))))


const func boolean: palindrome (in string: stri) is func
  result
    var boolean: isPalindrome is TRUE;
  local
    var integer: index is 0;
    var integer: length is 0;
  begin
    length := length(stri);
    for index range 1 to length div 2 do
      if stri[index] <> stri[length - index + 1] then
        isPalindrome := FALSE;
      end if;
    end for;
  end func;


import <Utilities/Sequence.sl>;

isPalindrome(string(1)) := equalList(string, reverse(string));


BEGIN

    BOOLEAN PROCEDURE ISPALINDROME(T); TEXT T;
    BEGIN
        BOOLEAN RESULT;
        INTEGER I, J;
        I := 1;
        J := T.LENGTH;
        RESULT := TRUE;
        WHILE RESULT AND I < J DO
        BEGIN
            CHARACTER L, R;
            T.SETPOS(I); L := T.GETCHAR; I := I + 1;
            T.SETPOS(J); R := T.GETCHAR; J := J - 1;
            RESULT := L = R;
        END;
        ISPALINDROME := RESULT;
    END ISPALINDROME;

    TEXT T;
    FOR T :- "", "A", "AA", "ABA", "SALALAS", "MADAMIMADAM",
             "AB", "AAB", "ABCBDA"
    DO
    BEGIN
        OUTTEXT(IF ISPALINDROME(T) THEN "IS   " ELSE "ISN'T");
        OUTTEXT(" PALINDROME: ");
        OUTCHAR('"');
        OUTTEXT(T);
        OUTCHAR('"');
        OUTIMAGE;
    END;

END.


[email protected](String traits) isPalindrome
[
  (s lexicographicallyCompare: s reversed) isZero
].


isPalindrome := [:aString |
	str := (aString select: [:chr| chr isAlphaNumeric]) collect: [:chr | chr asLowercase].
	str = str reversed.
	].


        define('pal(str)') :(pal_end)
pal     str notany(&ucase &lcase) = :s(pal)
        str = replace(str,&ucase,&lcase)
        leq(str,reverse(str)) :s(return)f(freturn)
pal_end

        define('palchk(str)tf') :(palchk_end)
palchk  output = str;
        tf = 'False'; tf = pal(str) 'True'
        output = 'Palindrome: ' tf :(return)
palchk_end

*       # Test and display
        palchk('Able was I ere I saw Elba')
        palchk('In girum imus nocte et consumimur igni')
        palchk('The quick brown fox jumped over the lazy dogs')
end


SET @txt = REPLACE('In girum imus nocte et consumimur igni', ' ', '');
SELECT REVERSE(@txt) = @txt;


import Foundation

// Allow for easy character checking
extension String {
    subscript (i: Int) -> String {
        return String(Array(self)[i])
    }
}

func isPalindrome(str:String) -> Bool {
    if (count(str) == 0 || count(str) == 1) {
        return true
    }
    let removeRange = Range<String.Index>(start: advance(str.startIndex, 1), end: advance(str.endIndex, -1))
    if (str[0] == str[count(str) - 1]) {
        return isPalindrome(str.substringWithRange(removeRange))
    }
    return false
}


templates palindrome
  [$...] -> #
  when <=$(last..first:-1)> do '$...;' !
end palindrome

[['rotor', 'racecar', 'level', 'rosetta']... -> palindrome ] -> !OUT::write


package require Tcl 8.5
proc palindrome {s} {
    return [expr {$s eq [string reverse $s]}]
}


$$ MODE TUSCRIPT
pal  ="ingirumimusnocteetconsumimurigni"
pal_r=TURN(pal)
SELECT pal
CASE $pal_r
PRINT "true"
DEFAULT
PRINT/ERROR "untrue"
ENDSELECT


const detectNonLetterRegexp=/[^A-ZÀ-ÞЀ-Я]/g;

function stripDiacritics(phrase:string){
    return phrase.normalize('NFD').replace(/[\u0300-\u036f]/g, "")
}

function isPalindrome(phrase:string){
    const TheLetters = stripDiacritics(phrase.toLocaleUpperCase().replace(detectNonLetterRegexp, ''));
    const middlePosition = TheLetters.length/2;
    const leftHalf = TheLetters.substr(0, middlePosition);
    const rightReverseHalf = TheLetters.substr(-middlePosition).split('').reverse().join('');
    return leftHalf == rightReverseHalf;
}

console.log(isPalindrome('Sueño que esto no es un palíndromo'))
console.log(isPalindrome('Dábale arroz a la zorra el abad!'))
console.log(isPalindrome('Я иду с мечем судия'))


if [[ "${text}" == "$(rev <<< "${text}")" ]]; then
   echo "Palindrome"
else
   echo "Not a palindrome"
fi


#import std

palindrome = ~&cixE\letters+ * -:~& ~=`A-~rlp letters


bool is_palindrome (string str) {
    var tmp = str.casefold ().replace (" ", "");
    return tmp == tmp.reverse ();
}

int main (string[] args) {
    print (is_palindrome (args[1]).to_string () + "\n");
    return 0;
}


Public Function isPalindrome(aString as string) as Boolean
dim tempstring as string
  tempstring = Lcase(Replace(aString, " ", ""))
  isPalindrome = (tempstring = Reverse(tempstring))
End Function


function Squish( s1 )
	dim sRes
	sRes = vbNullString
	dim i, c
	for i = 1 to len( s1 )
		c = lcase( mid( s1, i, 1 ))
		if instr( "abcdefghijklmnopqrstuvwxyz0123456789", c ) then
			sRes = sRes & c
		end if
	next
	Squish = sRes
end function

function isPalindrome( s1 )
	dim squished
	squished = Squish( s1 )
	isPalindrome = ( squished = StrReverse( squished ) )
end function


Module Module1

    Function IsPalindrome(p As String) As Boolean
        Dim temp = p.ToLower().Replace(" ", "")
        Return StrReverse(temp) = temp
    End Function

    Sub Main()
        Console.WriteLine(IsPalindrome("In girum imus nocte et consumimur igni"))
    End Sub

End Module


fn is_pal(ss string) bool {
    s := ss.runes()
    for i in 0..s.len/2 {
        if s[i] != s[s.len-1-i]{
            return false
        }
    }
    return true
}

fn main() {
    for word in ["rotor", "rosetta", "step on no pets", "été", "wren", "🦊😀🦊"] {
        println('$word => ${is_pal(word)}')
    }
}


@let {
  ; Using a hook
  pal1 @(= @rev)
  ; Function with argument
  pal2 &s = s @rev s
  ; for inexact palindromes
  pal3 ^(@(= @rev) .toLowerCase. &\@replace[&"\s+"g ""])
  [[
    !pal1 "abcba"
    !pal2 "abcbac"
    !pal3 "In girum imus nocte et consumimur igni"
  ]]
}


var isPal = Fn.new { |word| word == ((word.count > 0) ? word[-1..0] : "") }

System.print("Are the following palindromes?")
for (word in ["rotor", "rosetta", "step on no pets", "été", "wren", "🦊😀🦊"]) {
    System.print("  %(word) => %(isPal.call(word))")
}


; x86_84 Linux nasm
section .text

isPalindrome:
  mov rsi, rax
  mov rdi, rax

  get_end:
    cmp byte [rsi], 0
    je get_result
    inc rsi
    jmp get_end

  get_result:
    mov rax, 0
    dec rsi

    compare:
      mov cl, byte [rdi]
      cmp byte [rsi], cl
      jne not_palindrome
      cmp rsi, rdi
      je palindrome
      inc rdi
      cmp rdi, rsi
      je palindrome
      dec rsi
      jmp compare

  not_palindrome:
    mov rax, 0
    ret
  palindrome:
    mov rax, 1
    ret


include c:\cxpl\codes;          \intrinsic 'code' declarations
string 0;                       \use zero-terminated strings

func StrLen(Str);               \Return number of characters in an ASCIIZ string
char Str;
int  I;
for I:= 0 to -1>>1-1 do
        if Str(I) = 0 then return I;

func Palindrome(S);             \Return 'true' if S is a palindrome
char S;
int  L, I;
[L:= StrLen(S);
for I:= 0 to L/2-1 do
        if S(I) # S(L-1-I) then return false;
return true;
]; \Palindrome

int Word, I;
[Word:=
    ["otto", "mary", "ablewasiereisawelba", "ingirumimusnocteetconsumimurigni"];
for I:= 0 to 4-1 do
    [Text(0, if Palindrome(Word(I)) then "yes" else "no");
    CrLf(0);
    ];
]


func is_palindrome(str) {
    s = strchar(str)(:-1);
    return allof(s == s(::-1));
}

func prep_palindrome(str) {
    s = strchar(strlower(str));
    w = where(s >= 'a' & s <= 'z');
    return strchar(s(w));
}


fcn pali(text){
   if (text.len()<2) return(False);
   text==text.reverse();
}
fcn pali2(text){ pali((text - " \t\n.,").toLower()) }  // or whatever punctuation is


program: palindrome
  case: 1
        input: abcdcba
        output: true

  case: 2
        input: dog
        output: false

  case: 3
        input: x
        output: true

  case: 4
        input: abc
        output: false


F order_disjoint_list_items(&data, items)
   [Int] itemindices
   L(item) Set(items)
      V itemcount = items.count(item)
      V lastindex = [-1]
      L(i) 0 .< itemcount
         lastindex.append(data.index(item, lastindex.last + 1))
      itemindices [+]= lastindex[1..]
   itemindices.sort()
   L(index, item) zip(itemindices, items)
      data[index] = item

F slist(s)
   R Array(s).map(String)

F tostring(l)
   R ‘'’l.join(‘ ’)‘'’

L(data, items) [(‘the cat sat on the mat’.split(‘ ’), (‘mat cat’).split(‘ ’)),
                (‘the cat sat on the mat’.split(‘ ’), (‘cat mat’).split(‘ ’)),
                (slist(‘ABCABCABC’), slist(‘CACA’)),
                (slist(‘ABCABDABE’), slist(‘EADA’)),
                (slist(‘AB’), slist(‘B’)),
                (slist(‘AB’), slist(‘BA’)),
                (slist(‘ABBA’), slist(‘BA’)),
                (slist(‘’), slist(‘’)),
                (slist(‘A’), slist(‘A’)),
                (slist(‘AB’), slist(‘’)),
                (slist(‘ABBA’), slist(‘AB’)),
                (slist(‘ABAB’), slist(‘AB’)),
                (slist(‘ABAB’), slist(‘BABA’)),
                (slist(‘ABCCBA’), slist(‘ACAC’)),
                (slist(‘ABCCBA’), slist(‘CACA’))]
   print(‘Data M: #<24 Order N: #<9’.format(tostring(data), tostring(items)), end' ‘ ’)
   order_disjoint_list_items(&data, items)
   print(‘-> M' #.’.format(tostring(data)))


---------------------- DISJOINT ORDER --------------------

-- disjointOrder :: String -> String -> String
on disjointOrder(m, n)
    set {ms, ns} to map(my |words|, {m, n})

    unwords(flatten(zip(segments(ms, ns), ns & "")))
end disjointOrder

-- segments :: [String] -> [String] -> [String]
on segments(ms, ns)
    script segmentation
        on |λ|(a, x)
            set wds to |words| of a

            if wds contains x then
                {parts:(parts of a) & ¬
                    [current of a], current:[], |words|:deleteFirst(x, wds)} ¬

            else
                {parts:(parts of a), current:(current of a) & x, |words|:wds}
            end if
        end |λ|
    end script

    tell foldl(segmentation, {|words|:ns, parts:[], current:[]}, ms)
        (parts of it) & [current of it]
    end tell
end segments

--------------------------- TEST -------------------------
on run
    script order
        on |λ|(rec)
            tell rec
                [its m, its n, my disjointOrder(its m, its n)]
            end tell
        end |λ|
    end script

    arrowTable(map(order, [¬
        {m:"the cat sat on the mat", n:"mat cat"}, ¬
        {m:"the cat sat on the mat", n:"cat mat"}, ¬
        {m:"A B C A B C A B C", n:"C A C A"}, ¬
        {m:"A B C A B D A B E", n:"E A D A"}, ¬
        {m:"A B", n:"B"}, {m:"A B", n:"B A"}, ¬
        {m:"A B B A", n:"B A"}]))

    -- the cat sat on the mat  ->  mat cat  ->  the mat sat on the cat
    -- the cat sat on the mat  ->  cat mat  ->  the cat sat on the mat
    -- A B C A B C A B C       ->  C A C A  ->  C B A C B A A B C
    -- A B C A B D A B E       ->  E A D A  ->  E B C A B D A B A
    -- A B                     ->  B        ->  A B
    -- A B                     ->  B A      ->  B A
    -- A B B A                 ->  B A      ->  B A B A

end run

------------------------ FORMATTING ----------------------

-- arrowTable :: [[String]] -> String
on arrowTable(rows)

    script leftAligned
        script width
            on |λ|(a, b)
                (length of a) - (length of b)
            end |λ|
        end script

        on |λ|(col)
            set widest to length of maximumBy(width, col)

            script padding
                on |λ|(s)
                    justifyLeft(widest, space, s)
                end |λ|
            end script

            map(padding, col)
        end |λ|
    end script

    script arrows
        on |λ|(row)
            intercalate("  ->  ", row)
        end |λ|
    end script

    intercalate(linefeed, ¬
        map(arrows, ¬
            transpose(map(leftAligned, transpose(rows)))))
end arrowTable

-------------------- GENERIC FUNCTIONS -------------------

-- concatMap :: (a -> [b]) -> [a] -> [b]
on concatMap(f, xs)
    script append
        on |λ|(a, b)
            a & b
        end |λ|
    end script

    foldl(append, {}, map(f, xs))
end concatMap

-- deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
on deleteBy(fnEq, x, xs)
    if length of xs > 0 then
        set {h, t} to uncons(xs)
        if |λ|(x, h) of mReturn(fnEq) then
            t
        else
            {h} & deleteBy(fnEq, x, t)
        end if
    else
        {}
    end if
end deleteBy

-- deleteFirst :: a -> [a] -> [a]
on deleteFirst(x, xs)
    script Eq
        on |λ|(a, b)
            a = b
        end |λ|
    end script

    deleteBy(Eq, x, xs)
end deleteFirst

-- flatten :: Tree a -> [a]
on flatten(t)
    if class of t is list then
        concatMap(my flatten, t)
    else
        t
    end if
end flatten

-- foldl :: (a -> b -> a) -> a -> [b] -> a
on foldl(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from 1 to lng
            set v to |λ|(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldl

-- intercalate :: Text -> [Text] -> Text
on intercalate(strText, lstText)
    set {dlm, my text item delimiters} to {my text item delimiters, strText}
    set strJoined to lstText as text
    set my text item delimiters to dlm
    return strJoined
end intercalate

-- justifyLeft :: Int -> Char -> Text -> Text
on justifyLeft(n, cFiller, strText)
    if n > length of strText then
        text 1 thru n of (strText & replicate(n, cFiller))
    else
        strText
    end if
end justifyLeft

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- maximumBy :: (a -> a -> Ordering) -> [a] -> a
on maximumBy(f, xs)
    set cmp to mReturn(f)
    script max
        on |λ|(a, b)
            if a is missing value or cmp's |λ|(a, b) < 0 then
                b
            else
                a
            end if
        end |λ|
    end script

    foldl(max, missing value, xs)
end maximumBy

-- minimum :: [a] -> a
on minimum(xs)
    script min
        on |λ|(a, x)
            if x < a or a is missing value then
                x
            else
                a
            end if
        end |λ|
    end script

    foldl(min, missing value, xs)
end minimum

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- Egyptian multiplication - progressively doubling a list, appending
-- stages of doubling to an accumulator where needed for binary
-- assembly of a target length

-- replicate :: Int -> a -> [a]
on replicate(n, a)
    set out to {}
    if n < 1 then return out
    set dbl to {a}

    repeat while (n > 1)
        if (n mod 2) > 0 then set out to out & dbl
        set n to (n div 2)
        set dbl to (dbl & dbl)
    end repeat
    return out & dbl
end replicate

-- transpose :: [[a]] -> [[a]]
on transpose(xss)
    script column
        on |λ|(_, iCol)
            script row
                on |λ|(xs)
                    item iCol of xs
                end |λ|
            end script

            map(row, xss)
        end |λ|
    end script

    map(column, item 1 of xss)
end transpose

-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    if length of xs > 0 then
        {item 1 of xs, rest of xs}
    else
        missing value
    end if
end uncons

-- unwords :: [String] -> String
on unwords(xs)
    intercalate(space, xs)
end unwords

-- words :: String -> [String]
on |words|(s)
    words of s
end |words|

-- zip :: [a] -> [b] -> [(a, b)]
on zip(xs, ys)
    script pair
        on |λ|(x, i)
            [x, item i of ys]
        end |λ|
    end script

    map(pair, items 1 thru minimum([length of xs, length of ys]) of xs)
end zip


orderDisjoint: function [m,n][
    ms: split.words m
    ns: split.words n

    indexes: new []

    loop ns 'item [
        idx: index ms item
        unless null? idx [
            'indexes ++ idx
            ms\[idx]: ""
        ]
    ]
    sort 'indexes

    loop.with:'i indexes 'idx ->
        ms\[idx]: ns\[i]

    return join.with:" " ms
]

process: function [a,b][
    print [a "|" b "->" orderDisjoint a b]
]

process "the cat sat on the mat" "mat cat"
process "the cat sat on the mat" "cat mat"
process "A B C A B C A B C" "C A C A"
process "A B C A B D A B E" "E A D A"
process "A B" "B"
process "A B" "B A"
process "A B B A" "B A"


Data := [ {M: "the cat sat on the mat", N: "mat cat"}
	, {M: "the cat sat on the mat", N: "cat mat"}
	, {M: "A B C A B C A B C", N: "C A C A"}
	, {M: "A B C A B D A B E", N: "E A D A"}
	, {M: "A B", N: "B"}
	, {M: "A B", N: "B A"}
	, {M: "A B B A", N: "B A"} ]

for Key, Val in Data
	Output .= Val.M " :: " Val.N " -> " OrderDisjointList(Val.M, Val.N) "`n"
MsgBox, % RTrim(Output, "`n")

OrderDisjointList(M, N) {
	ItemsN := []
	Loop, Parse, N, % A_Space
		ItemsN[A_LoopField] := ItemsN[A_LoopField] ? ItemsN[A_LoopField] + 1 : 1
	N := StrSplit(N, A_Space)
	Loop, Parse, M, % A_Space
		Result .= (ItemsN[A_LoopField]-- > 0 ? N.Remove(1) : A_LoopField) " "
	return RTrim(Result)
}


( ( odli
  =   M N NN item A Z R
    .   !arg:(?M.?N)
      & :?NN
      &   whl
        ' ( !N:%?item ?N
          & (   !M:?A !item ?Z
              & !A (.) !Z:?M
              & !NN !item:?NN
            |
            )
          )
      & :?R
      &   whl
        ' ( !M:?A (.) ?M
          & !NN:%?item ?NN
          & !R !A !item:?R
          )
      & !R !M
  )
&     (the cat sat on the mat.mat cat)
      (the cat sat on the mat.cat mat)
      (A B C A B C A B C.C A C A)
      (A B C A B D A B E.E A D A)
      (A B.B)
      (A B.B A)
      (A B B A.B A)
  : ?tests
&   whl
  ' ( !tests:(?M.?N) ?tests
    & put$("Data M:" !M)
    & put$("\tOrder N:" !N)
    & out$(\t odli$(!M.!N))
    )
);


#include <iostream>
#include <vector>
#include <algorithm>
#include <string>

template <typename T>
void print(const std::vector<T> v) {
  std::cout << "{ ";
  for (const auto& e : v) {
    std::cout << e << " ";
  }
  std::cout << "}";
}

template <typename T>
auto orderDisjointArrayItems(std::vector<T> M, std::vector<T> N) {
  std::vector<T*> M_p(std::size(M));
  for (auto i = 0; i < std::size(M_p); ++i) {
    M_p[i] = &M[i];
  }
  for (auto e : N) {
    auto i = std::find_if(std::begin(M_p), std::end(M_p), [e](auto c) -> bool {
      if (c != nullptr) {
        if (*c == e) return true;
      }
      return false;
    });
    if (i != std::end(M_p)) {
      *i = nullptr;
    }
  }
  for (auto i = 0; i < std::size(N); ++i) {
    auto j = std::find_if(std::begin(M_p), std::end(M_p), [](auto c) -> bool {
      return c == nullptr;
    });
    if (j != std::end(M_p)) {
      *j = &M[std::distance(std::begin(M_p), j)];
      **j = N[i];
    }
  }
  return M;
}

int main() {
  std::vector<std::vector<std::vector<std::string>>> l = {
    { { "the", "cat", "sat", "on", "the", "mat" }, { "mat", "cat" } },
    { { "the", "cat", "sat", "on", "the", "mat" },{ "cat", "mat" } },
    { { "A", "B", "C", "A", "B", "C", "A", "B", "C" },{ "C", "A", "C", "A" } },
    { { "A", "B", "C", "A", "B", "D", "A", "B", "E" },{ "E", "A", "D", "A" } },
    { { "A", "B" },{ "B" } },
    { { "A", "B" },{ "B", "A" } },
    { { "A", "B", "B", "A" },{ "B", "A" } }
  };
  for (const auto& e : l) {
    std::cout << "M: ";
    print(e[0]);
    std::cout << ", N: ";
    print(e[1]);
    std::cout << ", M': ";
    auto res = orderDisjointArrayItems<std::string>(e[0], e[1]);
    print(res);
    std::cout << std::endl;
  }
  std::cin.ignore();
  std::cin.get();
  return 0;
}


(defun order-disjoint (data order)
  (let ((order-b (make-hash-table :test 'equal)))
    (loop :for n :in order :do (incf (gethash n order-b 0)))
    (loop :for m :in data :collect
       (cond ((< 0 (gethash m order-b 0))
              (decf (gethash m order-b))
              (pop order))
             (t m)))))


import std.stdio, std.string, std.algorithm, std.array, std.range,
       std.conv;

T[] orderDisjointArrayItems(T)(in T[] data, in T[] items)
pure /*nothrow*/ @safe {
    int[] itemIndices;
    foreach (item; items.dup.sort().uniq) {
        immutable int itemCount = items.count(item);
        assert(data.count(item) >= itemCount,
               text("More of ", item, " than in data"));
        auto lastIndex = [-1];
        foreach (immutable _; 0 .. itemCount) {
            immutable start = lastIndex.back + 1;
            lastIndex ~= data[start .. $].countUntil(item) + start;
        }
        itemIndices ~= lastIndex.dropOne;
    }

    itemIndices.sort();
    auto result = data.dup;
    foreach (index, item; zip(itemIndices, items))
        result[index] = item;
    return result;
}

void main() {
    immutable problems =
   "the cat sat on the mat  | mat cat
    the cat sat on the mat  | cat mat
    A B C A B C A B C       | C A C A
    A B C A B D A B E       | E A D A
    A B                     | B
    A B                     | B A
    A B B A                 | B A
                            |
    A                       | A
    A B                     |
    A B B A                 | A B
    A B A B                 | A B
    A B A B                 | B A B A
    A B C C B A             | A C A C
    A B C C B A             | C A C A"
    .splitLines.map!(r => r.split("|")).array;

    foreach (immutable p; problems) {
        immutable a = p[0].split;
        immutable b = p[1].split;
        writefln("%s | %s -> %-(%s %)", p[0].strip, p[1].strip,
                 orderDisjointArrayItems(a, b));
    }
}


(lib 'list) ;; for list-delete

(define dataM
'((the cat sat on the mat)
(the cat sat on the mat)
(A B C A B C A B C)
(A B C A B D A B E)
(A B)
(A B)
(A B B A)))

(define orderM
'((mat cat)
(cat mat)
(C A C A)
(E A D A)
(B)
(B A)
(B A)))

(define (order-disjoint M N)
(define R (append N null)) ;; tmp copy of N : delete w when used
	(for/list [(w M)]
	(if
		(not (member w R)) w ;; output as is
		(begin0
		(first N) ;; replacer
		(set! N (rest N))
		(set! R (list-delete R w))))))


defmodule Order do
  def disjoint(m,n) do
    IO.write "#{Enum.join(m," ")} | #{Enum.join(n," ")} -> "
    Enum.chunk(n,2)
    |> Enum.reduce({m,0}, fn [x,y],{m,from} ->
         md = Enum.drop(m, from)
         if x > y and x in md and y in md do
           if Enum.find_index(md,&(&1==x)) > Enum.find_index(md,&(&1==y)) do
             new_from = max(Enum.find_index(m,&(&1==x)), Enum.find_index(m,&(&1==y))) + 1
             m = swap(m,from,x,y)
             from = new_from
           end
         end
         {m,from}
       end)
    |> elem(0)
    |> Enum.join(" ")
    |> IO.puts
  end

  defp swap(m,from,x,y) do
    ix = Enum.find_index(m,&(&1==x)) + from
    iy = Enum.find_index(m,&(&1==y)) + from
    vx = Enum.at(m,ix)
    vy = Enum.at(m,iy)
    m |> List.replace_at(ix,vy) |> List.replace_at(iy,vx)
  end
end

[ {"the cat sat on the mat", "mat cat"},
  {"the cat sat on the mat", "cat mat"},
  {"A B C A B C A B C"     , "C A C A"},
  {"A B C A B D A B E"     , "E A D A"},
  {"A B"                   , "B"},
  {"A B"                   , "B A"},
  {"A B B A"               , "B A"}     ]
|> Enum.each(fn {m,n} ->
     Order.disjoint(String.split(m),String.split(n))
   end)


qw{ the cat sat on the mat } qw{ mat cat } make-slots


package main

import (
	"fmt"
	"sort"
	"strings"
)

type indexSort struct {
	val sort.Interface
	ind []int
}

func (s indexSort) Len() int           { return len(s.ind) }
func (s indexSort) Less(i, j int) bool { return s.ind[i] < s.ind[j] }
func (s indexSort) Swap(i, j int) {
	s.val.Swap(s.ind[i], s.ind[j])
	s.ind[i], s.ind[j] = s.ind[j], s.ind[i]
}

func disjointSliceSort(m, n []string) []string {
	s := indexSort{sort.StringSlice(m), make([]int, 0, len(n))}
	used := make(map[int]bool)
	for _, nw := range n {
		for i, mw := range m {
			if used[i] || mw != nw {
				continue
			}
			used[i] = true
			s.ind = append(s.ind, i)
			break
		}
	}
	sort.Sort(s)
	return s.val.(sort.StringSlice)
}

func disjointStringSort(m, n string) string {
	return strings.Join(
		disjointSliceSort(strings.Fields(m), strings.Fields(n)), " ")
}

func main() {
	for _, data := range []struct{ m, n string }{
		{"the cat sat on the mat", "mat cat"},
		{"the cat sat on the mat", "cat mat"},
		{"A B C A B C A B C", "C A C A"},
		{"A B C A B D A B E", "E A D A"},
		{"A B", "B"},
		{"A B", "B A"},
		{"A B B A", "B A"},
	} {
		mp := disjointStringSort(data.m, data.n)
		fmt.Printf("%s → %s » %s\n", data.m, data.n, mp)
	}

}


import Data.List (mapAccumL, sort)

order
  :: Ord a
  => [[a]] -> [a]
order [ms, ns] = snd . mapAccumL yu ls $ ks
  where
    ks = zip ms [(0 :: Int) ..]
    ls = zip ns . sort . snd . foldl go (sort ns, []) . sort $ ks
    yu ((u, v):us) (_, y)
      | v == y = (us, u)
    yu ys (x, _) = (ys, x)
    go (u:us, ys) (x, y)
      | u == x = (us, y : ys)
    go ts _ = ts

task :: [String] -> IO ()
task ls@[ms, ns] =
  putStrLn $
  "M: " ++ ms ++ " | N: " ++ ns ++ " |> " ++ (unwords . order . map words $ ls)

main :: IO ()
main =
  mapM_
    task
    [ ["the cat sat on the mat", "mat cat"]
    , ["the cat sat on the mat", "cat mat"]
    , ["A B C A B C A B C", "C A C A"]
    , ["A B C A B D A B E", "E A D A"]
    , ["A B", "B"]
    , ["A B", "B A"]
    , ["A B B A", "B A"]
    ]


procedure main(A)
    every write(" -> ",odli("the cat sat on the mat","mat cat"))
    every write(" -> ",odli("the cat sat on the mat","cat mat"))
    every write(" -> ",odli("A B C A B C A B C","C A C A"))
    every write(" -> ",odli("A B C A B D A B E","E A D A"))
    every write(" -> ",odli("A B","B"))
    every write(" -> ",odli("A B","B A"))
    every write(" -> ",odli("A B B A","B A"))
end

procedure odli(M,N)
    writes(M," :: ",N)
    Mp := ""
    P := N ||:= " "
    (M||" ") ? while item := tab(upto(' '))||move(1) do {
            if find(item,P) then {
                P ?:= 1(tab(find(item)),move(*item))||tab(0)
                N ?:= (item := tab(upto(' '))||move(1), tab(0))
                }
            Mp ||:= item
            }
    return Mp
end


disjorder=:3 :0&.;:
:
  clusters=. (</. [email protected]#) x
  order=. x i.&~. y
  need=. #/.~ y
  from=. ;need (#{.)each (/:~order){clusters
  to=. ;need {.!._ each order{clusters
  (from{x) to} x
)


import java.util.Arrays;
import java.util.BitSet;
import org.apache.commons.lang3.ArrayUtils;

public class OrderDisjointItems {

    public static void main(String[] args) {
        final String[][] MNs = {{"the cat sat on the mat", "mat cat"},
        {"the cat sat on the mat", "cat mat"},
        {"A B C A B C A B C", "C A C A"}, {"A B C A B D A B E", "E A D A"},
        {"A B", "B"}, {"A B", "B A"}, {"A B B A", "B A"}, {"X X Y", "X"}};

        for (String[] a : MNs) {
            String[] r = orderDisjointItems(a[0].split(" "), a[1].split(" "));
            System.out.printf("%s | %s -> %s%n", a[0], a[1], Arrays.toString(r));
        }
    }

    // if input items cannot be null
    static String[] orderDisjointItems(String[] m, String[] n) {
        for (String e : n) {
            int idx = ArrayUtils.indexOf(m, e);
            if (idx != -1)
                m[idx] = null;
        }
        for (int i = 0, j = 0; i < m.length; i++) {
            if (m[i] == null)
                m[i] = n[j++];
        }
        return m;
    }

    // otherwise
    static String[] orderDisjointItems2(String[] m, String[] n) {
        BitSet bitSet = new BitSet(m.length);
        for (String e : n) {
            int idx = -1;
            do {
                idx = ArrayUtils.indexOf(m, e, idx + 1);
            } while (idx != -1 && bitSet.get(idx));
            if (idx != -1)
                bitSet.set(idx);
        }
        for (int i = 0, j = 0; i < m.length; i++) {
            if (bitSet.get(i))
                m[i] = n[j++];
        }
        return m;
    }
}


V words = File(‘unixdict.txt’).read().split("\n")
V ordered = words.filter(word -> word == sorted(word).join(‘’))
V maxlen = max(ordered, key' w -> w.len).len
V maxorderedwords = ordered.filter(word -> word.len == :maxlen)
print(maxorderedwords.join(‘ ’))


(() => {
    "use strict";

    // ------------ ORDER DISJOINT LIST ITEMS ------------

    // disjointOrder :: [String] -> [String] -> [String]
    const disjointOrder = ms =>
        ns => zipWith(
            a => b => [...a, b]
        )(
            segments(ms)(ns)
        )(
            ns.concat("")
        )
        .flat();

    // segments :: [String] -> [String] -> [String]
    const segments = ms =>
        ns => {
            const dct = ms.reduce((a, x) => {
                const
                    wds = a.words,
                    found = wds.indexOf(x) !== -1;

                return {
                    parts: [
                        ...a.parts,
                        ...(found ? [a.current] : [])
                    ],
                    current: found ? [] : [...a.current, x],
                    words: found ? deleteFirst(x)(wds) : wds
                };
            }, {
                words: ns,
                parts: [],
                current: []
            });

            return [...dct.parts, dct.current];
        };

    // ---------------------- TEST -----------------------
    const main = () =>
        transpose(transpose([{
                M: "the cat sat on the mat",
                N: "mat cat"
            }, {
                M: "the cat sat on the mat",
                N: "cat mat"
            }, {
                M: "A B C A B C A B C",
                N: "C A C A"
            }, {
                M: "A B C A B D A B E",
                N: "E A D A"
            }, {
                M: "A B",
                N: "B"
            }, {
                M: "A B",
                N: "B A"
            }, {
                M: "A B B A",
                N: "B A"
            }].map(dct => [
                dct.M, dct.N,
                unwords(
                    disjointOrder(
                        words(dct.M)
                    )(
                        words(dct.N)
                    )
                )
            ]))
            .map(col => {
                const
                    w = maximumBy(
                        comparing(x => x.length)
                    )(col).length;

                return col.map(justifyLeft(w)(" "));
            }))
        .map(
            ([a, b, c]) => `${a}  ->  ${b}  ->  ${c}`
        )
        .join("\n");

    // ---------------- GENERIC FUNCTIONS ----------------

    // comparing :: (a -> b) -> (a -> a -> Ordering)
    const comparing = f =>
        // The ordering of f(x) and f(y) as a value
        // drawn from {-1, 0, 1}, representing {LT, EQ, GT}.
        x => y => {
            const
                a = f(x),
                b = f(y);

            return a < b ? -1 : (a > b ? 1 : 0);
        };

    // deleteFirst :: a -> [a] -> [a]
    const deleteFirst = x => {
        const go = xs => Boolean(xs.length) ? (
            x === xs[0] ? (
                xs.slice(1)
            ) : [xs[0]].concat(go(xs.slice(1)))
        ) : [];

        return go;
    };

    // unwords :: [String] -> String
    const unwords = xs =>
        // A space-separated string derived
        // from a list of words.
        xs.join(" ");

    // words :: String -> [String]
    const words = s =>
        // List of space-delimited sub-strings.
        s.split(/\s+/u);

    // zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
    const zipWith = f =>
        // A list constructed by zipping with a
        // custom function, rather than with the
        // default tuple constructor.
        xs => ys => xs.map(
            (x, i) => f(x)(ys[i])
        ).slice(
            0, Math.min(xs.length, ys.length)
        );

    // ---------------- FORMATTING OUTPUT ----------------

    // justifyLeft :: Int -> Char -> String -> String
    const justifyLeft = n =>
        // The string s, followed by enough padding (with
        // the character c) to reach the string length n.
        c => s => n > s.length ? (
            s.padEnd(n, c)
        ) : s;

    // maximumBy :: (a -> a -> Ordering) -> [a] -> a
    const maximumBy = f =>
        xs => Boolean(xs.length) ? (
            xs.slice(1).reduce(
                (a, x) => 0 < f(x)(a) ? (
                    x
                ) : a,
                xs[0]
            )
        ) : undefined;

    // transpose :: [[a]] -> [[a]]
    const transpose = rows =>
        // The columns of a matrix of consistent row length,
        // transposed into corresponding rows.
        Boolean(rows.length) ? rows[0].map(
            (_, i) => rows.flatMap(
                v => v[i]
            )
        ) : [];

    // MAIN ---
    return main();
})();


CHAR ARRAY line(256)

BYTE FUNC IsOrderedWord(CHAR ARRAY word)
  BYTE len,i

  len=word(0)
  IF len<=1 THEN RETURN (1) FI

  FOR i=1 TO len-1
  DO
    IF word(i)>word(i+1) THEN
      RETURN (0)
    FI
  OD
RETURN (1)

BYTE FUNC FindLongestOrdered(CHAR ARRAY fname)
  BYTE max,dev=[1]

  max=0
  Close(dev)
  Open(dev,fname,4)
  WHILE Eof(dev)=0
  DO
    InputSD(dev,line)
    IF line(0)>max AND IsOrderedWord(line)=1 THEN
      max=line(0)
    FI
  OD
  Close(dev)
RETURN (max)

PROC FindWords(CHAR ARRAY fname BYTE n)
  BYTE count,dev=[1]

  Close(dev)
  Open(dev,fname,4)
  WHILE Eof(dev)=0
  DO
    InputSD(dev,line)
    IF line(0)=n AND IsOrderedWord(line)=1 THEN
      Print(line) Put(32)
    FI
  OD
  Close(dev)
RETURN

PROC Main()
  CHAR ARRAY fname="H6:UNIXDICT.TXT"
  BYTE max

  PrintE("Finding the longest words...")
  PutE()
  max=FindLongestOrdered(fname)

  FindWords(fname,max)
RETURN


with Ada.Text_IO, Ada.Containers.Indefinite_Vectors;
use Ada.Text_IO;

procedure Ordered_Words is
   package Word_Vectors is new Ada.Containers.Indefinite_Vectors
      (Index_Type => Positive, Element_Type => String);
   use Word_Vectors;
   File : File_Type;
   Ordered_Words : Vector;
   Max_Length : Positive := 1;
begin
   Open (File, In_File, "unixdict.txt");
   while not End_Of_File (File) loop
      declare
         Word : String := Get_Line (File);
      begin
         if (for all i in Word'First..Word'Last-1 => Word (i) <= Word(i+1)) then
            if Word'Length > Max_Length then
               Max_Length := Word'Length;
               Ordered_Words.Clear;
               Ordered_Words.Append (Word);
            elsif Word'Length = Max_Length then
               Ordered_Words.Append (Word);
            end if;
         end if;
      end;
   end loop;
   for Word of Ordered_Words loop
     Put_Line (Word);
   end loop;
   Close (File);
end Ordered_Words;


def disjoint_order(N):
  # The helper function, indices, ensures that successive occurrences
  # of a particular value in N are matched by successive occurrences
  # in the input on the assumption that null is not initially in the input.
  def indices:
    . as $in
    | reduce range(0; N|length) as $i
       # state: [ array, indices ]
      ( [$in, []];
        (.[0] | index(N[$i])) as $ix | .[0][$ix] = null | .[1] += [$ix])
    | .[1];

  . as $in
  | (indices | sort) as $sorted
  | reduce range(0; N|length) as $i ($in; .[$sorted[$i]] = N[$i] ) ;


function order_disjoint{T<:AbstractArray}(m::T, n::T)
    rlen = length(n)
    rdis = zeros(Int, rlen)
    for (i, e) in enumerate(n)
        j = findfirst(m, e)
        while j in rdis && j != 0
            j = findnext(m, e, j+1)
        end
        rdis[i] = j
    end
    if 0 in rdis
        throw(DomainError())
    end
    sort!(rdis)
    p = copy(m)
    p[rdis] = n
    return p
end


// version 1.0.6

const val NULL = "\u0000"

fun orderDisjointList(m: String, n: String): String {
    val nList = n.split(' ')
    // first replace the first occurrence of items of 'n' in 'm' with the NULL character
    // which we can safely assume won't occur in 'm' naturally
    var p = m
    for (item in nList) p = p.replaceFirst(item, NULL)
    // now successively replace the NULLs with items from nList
    val mList = p.split(NULL)
    val sb = StringBuilder()
    for (i in 0 until nList.size) sb.append(mList[i], nList[i])
    return sb.append(mList.last()).toString()
}

fun main(args: Array<String>) {
    val m = arrayOf(
        "the cat sat on the mat",
        "the cat sat on the mat",
        "A B C A B C A B C",
        "A B C A B D A B E",
        "A B",
        "A B",
        "A B B A"
    )
    val n = arrayOf(
        "mat cat",
        "cat mat",
        "C A C A",
        "E A D A",
        "B",
        "B A",
        "B A"
    )
    for (i in 0 until m.size)
        println("${m[i].padEnd(22)}  ->  ${n[i].padEnd(7)}  ->  ${orderDisjointList(m[i], n[i])}")
}


-- Split str on any space characters and return as a table
function split (str)
    local t = {}
    for word in str:gmatch("%S+") do table.insert(t, word) end
    return t
end

-- Order disjoint list items
function orderList (dataStr, orderStr)
    local data, order = split(dataStr), split(orderStr)
    for orderPos, orderWord in pairs(order) do
        for dataPos, dataWord in pairs(data) do
            if dataWord == orderWord then
                data[dataPos] = false
                break
            end
        end
    end
    local orderPos = 1
    for dataPos, dataWord in pairs(data) do
        if not dataWord then
            data[dataPos] = order[orderPos]
            orderPos = orderPos + 1
            if orderPos > #order then return data end
        end
    end
    return data
end

-- Main procedure
local testCases = {
    {'the cat sat on the mat', 'mat cat'},
    {'the cat sat on the mat', 'cat mat'},
    {'A B C A B C A B C'     , 'C A C A'},
    {'A B C A B D A B E'     , 'E A D A'},
    {'A B'                   , 'B'},
    {'A B'                   , 'B A'},
    {'A B B A'               , 'B A'}
}
for _, example in pairs(testCases) do
    print(table.concat(orderList(unpack(example)), " "))
end


integer
ordered(data s)
{
    integer a, c, p;

    a = 1;

    p = -1;
    for (, c in s) {
        if (c < p) {
            a = 0;
            break;
        } else {
            p = c;
        }
    }

    a;
}

integer
main(void)
{
    file f;
    text s;
    index x;

    f.affix("unixdict.txt");

    while (f.line(s) != -1) {
        if (ordered(s)) {
            x.v_list(~s).append(s);
        }
    }

    l_ucall(x.back, o_, 0, "\n");

    return 0;
}


PROC ordered = (STRING s)BOOL:
  BEGIN
    FOR i TO UPB s - 1 DO IF s[i] > s[i+1] THEN return false FI OD;
    TRUE EXIT
    return false: FALSE
  END;

IF FILE input file;
   STRING file name = "unixdict.txt";
   open(input file, file name, stand in channel) /= 0
THEN
  print(("Unable to open file """ + file name + """", newline))
ELSE
  BOOL at eof := FALSE;
  on logical file end (input file, (REF FILE f)BOOL: at eof := TRUE);

  FLEX [1:0] STRING words;
  INT idx := 1;
  INT max length := 0;

  WHILE NOT at eof
  DO
    STRING word;
    get(input file, (word, newline));
    IF UPB word >= max length
    THEN IF ordered(word)
         THEN
           max length := UPB word;
           IF idx > UPB words
           THEN
             [1 : UPB words + 20] STRING tmp;
             tmp[1 : UPB words] := words;
             words := tmp
           FI;
           words[idx] := word;
           idx +:= 1
         FI
    FI
  OD;
  print(("Maximum length of ordered words: ", whole(max length, -4), newline));
  FOR i TO idx-1
  DO
    IF UPB words[i] = max length THEN print((words[i], newline)) FI
  OD
FI


Function Checkit$ {
	Document Ret$
	Flush
	Data "the cat sat on the mat", "mat cat"
	Data "the cat sat on the mat","cat mat"'
	Data "A B C A B C A B C", "C A C A"
	Data "A B C A B D A B E", "E A D A"
	Data "A B", "B"
	Data "A B", "B A"
	Data "A B B A","B A"
	Dim A$()
	while not empty
		read m$, n$
		A$()=piece$(m$, " ")
		Let w=piece$(n$, " ")
		Let z=A$()
		x=each(w)
		while x
			y=z#pos(array$(x))
			if y>-1 then a$(y)=""
		end while
		p=0
		x=each(w)
		while x
			while a$(p)<>"" : p++: end while
			a$(p)=array$(x)
		end while
		ret$=m$+" | "+n$+" -> "+z#str$()+{
		}
	end while
	=ret$
}
Report Checkit$()
Clipboard  Checkit$()


order[m_, n_] :=
  ReplacePart[m,
   MapThread[
    Rule, {Position[m, Alternatives @@ n][[;; Length[n]]], n}]];
Print[StringRiffle[
   order[{"the", "cat", "sat", "on", "the", "mat"}, {"mat",
     "cat"}]]];
Print[StringRiffle[
   order[{"the", "cat", "sat", "on", "the", "mat"}, {"cat",
     "mat"}]]];
Print[StringRiffle[
   order[{"A", "B", "C", "A", "B", "C", "A", "B", "C"}, {"C", "A",
     "C", "A"}]]];
Print[StringRiffle[
   order[{"A", "B", "C", "A", "B", "D", "A", "B", "E"}, {"E", "A",
     "D", "A"}]]];
Print[StringRiffle[order[{"A", "B"}, {"B"}]]];
Print[StringRiffle[order[{"A", "B"}, {"B", "A"}]]];
Print[StringRiffle[order[{"A", "B", "B", "A"}, {"B", "A"}]]];


import algorithm, strutils

proc orderDisjoint(m, n: string): string =

  # Build the list of items.
  var m = m.splitWhitespace()
  let n = n.splitWhitespace()

  # Find the indexes of items to replace.
  var indexes: seq[int]
  for item in n:
    let idx = m.find(item)
    if idx >= 0:
      indexes.add idx
      m[idx] = ""   # Set to empty string for next searches.
  indexes.sort()

  # Do the replacements.
  for i, idx in indexes:
    m[idx] = n[i]

  result = m.join(" ")

when isMainModule:

  template process(a, b: string) =
    echo a, " | ", b, " → ", orderDisjoint(a, b)

  process("the cat sat on the mat", "mat cat")
  process("the cat sat on the mat", "cat mat")
  process("A B C A B C A B C", "C A C A")
  process("A B C A B D A B E", "E A D A")
  process("A B", "B")
  process("A B", "B A")
  process("A B B A", "B A")


sub dsort {
        my ($m, $n) = @_;
        my %h;
        $h{$_}++ for @$n;
        map $h{$_}-- > 0 ? shift @$n : $_, @$m;
}

for (split "\n", <<"IN")
        the cat sat on the mat  | mat cat
        the cat sat on the mat  | cat mat
        A B C A B C A B C       | C A C A
        A B C A B D A B E       | E A D A
        A B                     | B
        A B                     | B A
        A B B A                 | B A
IN
{

        my ($a, $b) = map([split], split '\|');
        print "@$a | @$b -> @{[dsort($a, $b)]}\n";
}


result←longest_ordered_words file_path

f←file_path ⎕NTIE 0            ⍝ open file
text←⎕NREAD f 'char8'          ⍝ read vector of 8bit chars
⎕NUNTIE f                      ⍝ close file

lines←text⊂⍨~text∊(⎕UCS 10 13) ⍝ split into lines (\r\n)

⍝ filter only words with ordered characters
ordered_words←lines/⍨{(⍳∘≢≡⍋)⍵}¨lines

⍝ find max of word lengths, filter only words with that length
result←ordered_words/⍨lengths=⍨⌈/lengths←≢¨ordered_words


use AppleScript version "2.3.1" -- Mac OS 10.9 (Mavericks) or later — for these 'use' commands.
use sorter : script "Insertion sort" -- https://www.rosettacode.org/wiki/Sorting_algorithms/Insertion_sort#AppleScript.
use scripting additions

on longestOrderedWords(wordList)
    script o
        property allWords : wordList
        property orderedWords : {}
    end script

    set longestWordLength to 0
    set astid to AppleScript's text item delimiters
    set AppleScript's text item delimiters to ""
    ignoring case
        repeat with i from 1 to (count o's allWords)
            set thisWord to item i of o's allWords
            set thisWordLength to (count thisWord)
            if (thisWordLength ≥ longestWordLength) then
                set theseCharacters to thisWord's characters
                tell sorter to sort(theseCharacters, 1, -1)
                set sortedWord to theseCharacters as text
                if (sortedWord = thisWord) then
                    if (thisWordLength > longestWordLength) then
                        set o's orderedWords to {thisWord}
                        set longestWordLength to thisWordLength
                    else
                        set end of o's orderedWords to thisWord
                    end if
                end if
            end if
        end repeat
    end ignoring
    set AppleScript's text item delimiters to astid

    return (o's orderedWords)
end longestOrderedWords

-- Test code:
local wordList
set wordList to paragraphs of (read (((path to desktop as text) & "www.rosettacode.org:unixdict.txt") as alias) as «class utf8»)
-- ignoring white space, punctuation and diacriticals
return longestOrderedWords(wordList)
--- end ignoring


with javascript_semantics
function order_disjoint(sequence m, sequence n)
    integer rlen = length(n)
    sequence rdis = repeat(0,rlen)
    for i=1 to rlen do
        object e = n[i]
        integer j = find(e,m)
        while j!=0 and find(j,rdis) do
            j = find(e,m,j+1)
        end while
        rdis[i] = j
    end for
    rdis = sort(rdis)
    while rlen and rdis[1]=0 do
        rdis = rdis[2..$]
        rlen -= 1
    end while
    for i=1 to rlen do
        m[rdis[i]]=n[i]
    end for
    return join(m)
end function

sequence tests = {{"the cat sat on the mat","mat cat"},
                  {"the cat sat on the mat","cat mat"},
                  {"A B C A B C A B C","C A C A"},
                  {"A B C A B D A B E","E A D A"},
                  {"A B","B"},
                  {"A B","B A"},
                  {"A B B A","B A"},
                  {"",""},
                  {"A","A"},
                  {"A B",""},
                  {"A B B A","A B"},
                  {"A B A B","A B"},
                  {"A B A B","B A B A"},
                  {"A B C C B A","A C A C"},
                  {"A B C C B A","C A C A"},
                  {"A X","Y A"},
                  {"A X","Y A X"},
                  {"A X","Y X A"}}

for i=1 to length(tests) do
    string {m,n} = tests[i]
    printf(1,"\"%s\",\"%s\" => \"%s\"\n",{m,n,order_disjoint(split(m),split(n))})
end for


(de orderDisjoint (M N)
   (for S N
      (and (memq S M) (set @ NIL)) )
   (mapcar
      '((S) (or S (pop 'N)))
      M ) )


ordered?: function [w]->
    w = join sort split w

words: read.lines relative "unixdict.txt"
ret: new []
loop words 'wrd [
    if ordered? wrd ->
        'ret ++ #[w: wrd l: size wrd]
]

sort.descending.by: 'l 'ret
maxl: get first ret 'l
print sort map select ret 'x -> maxl = x\l
                          'x -> x\w


MaxLen=0
Loop, Read, UnixDict.txt         ; Assigns A_LoopReadLine to each line of the file
{
    thisword := A_LoopReadLine   ; Just for readability
    blSort := isSorted(thisWord) ; reduce calls to IsSorted to improve performance
    ThisLen := StrLen(ThisWord)  ; reduce calls to StrLen to improve performance
    If (blSort = true and ThisLen = maxlen)
        list .= ", " . thisword
    Else If (blSort = true and ThisLen > maxlen)
    {
        list := thisword
        maxlen := ThisLen
    }
}

IsSorted(word){  ; This function uses the ASCII value of the letter to determine its place in the alphabet.
                           ;        Thankfully, the dictionary is in all lowercase
    lastchar=0
    Loop, parse, word
    {
        if ( Asc(A_LoopField) < lastchar )
            return false
        lastchar := Asc(A_loopField)
    }
    return true
}

GUI, Add, Edit, w300 ReadOnly, %list%
GUI, Show
return ; End Auto-Execute Section

GUIClose:
ExitApp


function sublistsort($M, $N) {
    $arr = $M.Split(' ')
    $array = $N.Split(' ') | group
    $Count = @($array |foreach {$_.Count})
    $ip, $i = @(), 0
    $arr | foreach{
        $name = "$_"
        $j = $array.Name.IndexOf($name)
        if($j -gt -1){
            $k = $Count[$j] - 1
            if($k -ge 0) {
                $ip += @($i)
                $Count[$j] = $k
            }
        }
        $i++
    }
    $i = 0
    $N.Split(' ') | foreach{ $arr[$ip[$i++]] = "$_"}
    [pscustomobject]@{
        "M" = "$M "
        "N" = "$N "
        "M'" = "$($arr)"
    }
}
$M1 = 'the cat sat on the mat'
$N1 =  'mat cat'
$M2 = 'the cat sat on the mat'
$N2 = 'cat mat'
$M3 = 'A B C A B C A B C'
$N3 = 'C A C A'
$M4 = 'A B C A B D A B E'
$N4 = 'E A D A'
$M5 = 'A B'
$N5 = 'B'
$M6 = 'A B'
$N6 = 'B A'
$M7 = 'A B B A'
$N7 = 'B A'
sublistsort $M1 $N1
sublistsort $M2 $N2
sublistsort $M3 $N3
sublistsort $M4 $N4
sublistsort $M5 $N5
sublistsort $M6 $N6
sublistsort $M7 $N7


from __future__ import print_function

def order_disjoint_list_items(data, items):
    #Modifies data list in-place
    itemindices = []
    for item in set(items):
        itemcount = items.count(item)
        #assert data.count(item) >= itemcount, 'More of %r than in data' % item
        lastindex = [-1]
        for i in range(itemcount):
            lastindex.append(data.index(item, lastindex[-1] + 1))
        itemindices += lastindex[1:]
    itemindices.sort()
    for index, item in zip(itemindices, items):
        data[index] = item

if __name__ == '__main__':
    tostring = ' '.join
    for data, items in [ (str.split('the cat sat on the mat'), str.split('mat cat')),
                         (str.split('the cat sat on the mat'), str.split('cat mat')),
                         (list('ABCABCABC'), list('CACA')),
                         (list('ABCABDABE'), list('EADA')),
                         (list('AB'), list('B')),
                         (list('AB'), list('BA')),
                         (list('ABBA'), list('BA')),
                         (list(''), list('')),
                         (list('A'), list('A')),
                         (list('AB'), list('')),
                         (list('ABBA'), list('AB')),
                         (list('ABAB'), list('AB')),
                         (list('ABAB'), list('BABA')),
                         (list('ABCCBA'), list('ACAC')),
                         (list('ABCCBA'), list('CACA')),
                       ]:
        print('Data M: %-24r Order N: %-9r' % (tostring(data), tostring(items)), end=' ')
        order_disjoint_list_items(data, items)
        print("-> M' %r" % tostring(data))


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program orderlist64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessResult1:      .asciz "List1 < List2 \n"           // message result
szMessResult2:      .asciz "List1 => List2 \n"           // message result
szCarriageReturn:  .asciz "\n"

qTabList1:         .quad  1,2,3,4,5
.equ NBELEMENTS1,   (. - qTabList1) /8
qTabList2:         .quad  1,2,1,5,2,2
.equ NBELEMENTS2,   (. - qTabList2) /8
qTabList3:         .quad  1,2,3,4,5
.equ NBELEMENTS3,   (. - qTabList3) /8
qTabList4:         .quad  1,2,3,4,5,6
.equ NBELEMENTS4,   (. - qTabList4) /8
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                       // entry of program
    ldr x0,qAdriTabList1
    mov x1,NBELEMENTS1
    ldr x2,qAdriTabList2
    mov x3,NBELEMENTS2
    bl listeOrder
    cmp x0,0                                // false ?
    beq 1f                                  // yes
    ldr x0,qAdrszMessResult1                // list 1 < list 2
    bl affichageMess                        // display message
    b 2f
1:
    ldr x0,qAdrszMessResult2
    bl affichageMess                        // display message

2:
    ldr x0,qAdriTabList1
    mov x1,NBELEMENTS1
    ldr x2,qAdriTabList3
    mov x3,NBELEMENTS3
    bl listeOrder
    cmp x0,0                               // false ?
    beq 3f                                  // yes
    ldr x0,qAdrszMessResult1                // list 1 < list 2
    bl affichageMess                        // display message
    b 4f
3:
    ldr x0,qAdrszMessResult2
    bl affichageMess                        // display message
4:
    ldr x0,qAdriTabList1
    mov x1,NBELEMENTS1
    ldr x2,qAdriTabList4
    mov x3,NBELEMENTS4
    bl listeOrder
    cmp x0,0                               // false ?
    beq 5f                                  // yes
    ldr x0,qAdrszMessResult1                // list 1 < list 2
    bl affichageMess                        // display message
    b 6f
5:
    ldr x0,qAdrszMessResult2
    bl affichageMess                        // display message
6:
100:                                        // standard end of the program
    mov x0,0                              // return code
    mov x8,EXIT                           // request to exit program
    svc 0                                  // perform the system call
qAdriTabList1:             .quad qTabList1
qAdriTabList2:             .quad qTabList2
qAdriTabList3:             .quad qTabList3
qAdriTabList4:             .quad qTabList4
qAdrszMessResult1:         .quad szMessResult1
qAdrszMessResult2:         .quad szMessResult2
qAdrszCarriageReturn:      .quad szCarriageReturn
/******************************************************************/
/*     liste order                                                */
/******************************************************************/
/* x0 contains the address of list 1 */
/* x1 contains list 1 size           */
/* x2 contains the address of list 2 */
/* x3 contains list 2 size           */
/* x0 returns 1 if list1 < list2     */
/* x0 returns 0 else                 */
listeOrder:
    stp x1,lr,[sp,-16]!          // save  registers
    stp x2,x3,[sp,-16]!          // save  registers
    cbz x1,99f                    // list 1 size = zero ?
    cbz x3,98f                    // list 2 size = zero ?

    mov x4,#0                    // index list 1
    mov x5,#0                    // index list 2
1:
    ldr x6,[x0,x4,lsl #3]        // load list 1 element
    ldr x8,[x2,x5,lsl #3]        // load list 2 element
    cmp x6,x8                    // compar
    bgt 4f
    beq 2f                       // list 1 = list 2
    add x4,x4,1                  // increment index 1
    cmp x4,x1                    // end list ?
    bge 5f
    b 1b                         // else loop
2:
    add x4,x4,1                  // increment index 1
    cmp x4,x1                    // end list ?
    bge 3f                       // yes -> verif size
    add x5,x5,1                  // else increment index 2
    cmp x5,x3                    // end list 2 ?
    bge 4f
    b 1b                         // else loop
3:
    cmp x1,x3                     // compar size
    bge 4f                       // list 2 < list 1
    blt 5f                       // list 1 < list 2
    b 100f
4:
    mov x0,#0                    // list 1 > list 2
    b 100f
5:
    mov x0,#1                    //  list 1 < list 2
    b 100f
98:                              // error
    mov x0,-2
    b 100f
99:                              // error
    mov x0,-1
100:
    ldp x2,x3,[sp],16            // restaur  2 registers
    ldp x1,lr,[sp],16            // restaur  2 registers
    ret                          // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


INT FUNC Compare(INT ARRAY x INT xLen INT ARRAY y INT yLen)
  INT i,len

  len=xLen
  IF len>yLen THEN
    len=yLen
  FI
  FOR i=0 TO len-1
  DO
    IF x(i)>y(i) THEN
      RETURN (1)
    ELSEIF x(i)<y(i) THEN
      RETURN (-1)
    FI
  OD
  IF xLen>yLen THEN
    RETURN (1)
  ELSEIF xLen<yLen THEN
    RETURN (-1)
  FI
RETURN (0)

BYTE FUNC Less(INT ARRAY x INT xLen INT ARRAY y INT yLen)
  IF Compare(x,xLen,y,yLen)<0 THEN
    RETURN (1)
  FI
RETURN (0)

PROC PrintArray(INT ARRAY x INT len)
  INT i

  Put('[)
  FOR i=0 TO len-1
  DO
    PrintI(x(i))
    IF i<len-1 THEN
      Put(' )
    FI
  OD
  Put('])
RETURN

PROC Test(INT ARRAY x INT xLen INT ARRAY y INT yLen)
  PrintArray(x,xLen)
  IF Less(x,xLen,y,yLen) THEN
     Print(" < ")
  ELSE
    Print(" >= ")
  FI
  PrintArray(y,yLen) PutE()
RETURN

PROC Main()
  INT ARRAY a=[1 2 1 5 2]
  INT ARRAY b=[1 2 1 5 2 2]
  INT ARRAY c=[1 2 3 4 5]
  INT ARRAY d=[1 2 3 4 5]

  Test(a,5,b,6)
  Test(b,6,a,5)
  Test(b,6,c,5)
  Test(c,5,b,6)
  Test(c,5,d,5)
RETURN


with Ada.Text_IO;  use Ada.Text_IO;
procedure Order is

   type IntArray is array (Positive range <>) of Integer;
   List1 : IntArray := (1, 2, 3, 4, 5);
   List2 : IntArray := (1, 2, 1, 5, 2, 2);
   List3 : IntArray := (1, 2, 1, 5, 2);
   List4 : IntArray := (1, 2, 1, 5, 2);

   type Animal is (Rat, Cat, Elephant);
   type AnimalArray is array (Positive range <>) of Animal;
   List5 : AnimalArray := (Cat, Elephant, Rat, Cat);
   List6 : AnimalArray := (Cat, Elephant, Rat);
   List7 : AnimalArray := (Cat, Cat, Elephant);

begin
   Put_Line (Boolean'Image (List1 > List2)); --  True
   Put_Line (Boolean'Image (List2 > List3)); --  True
   Put_Line (Boolean'Image (List3 > List4)); --  False, equal
   Put_Line (Boolean'Image (List5 > List6)); --  True
   Put_Line (Boolean'Image (List6 > List7)); --  True
end Order;


BEGIN {
	abc = "abcdefghijklmnopqrstuvwxyz"
}

{
	# Check if this line is an ordered word.
	ordered = 1  # true
	left = -1
	for (i = 1; i <= length($0); i++) {
		right = index(abc, substr($0, i, 1))
		if (right == 0 || left > right) {
			ordered = 0  # false
			break
		}
		left = right
	}

	if (ordered) {
		score = length($0)
		if (score > best["score"]) {
			# Reset the list of best ordered words.
			best["score"] = score
			best["count"] = 1
			best[1] = $0
		} else if (score == best["score"]) {
			# Add this word to the list.
			best[++best["count"]] = $0
		}
	}
}

END {
	# Print the list of best ordered words.
	for (i = 1; i <= best["count"]; i++)
		print best[i]
}


'Ordered words - improved version
OPTION COLLAPSE TRUE

list$ = LOAD$("unixdict.txt")

FOR word$ IN list$ STEP NL$

    term$ = EXTRACT$(SORT$(EXPLODE$(word$, 1)), " ")

    IF word$ = term$ THEN
        IF LEN(term$) > MaxLen THEN
            MaxLen = LEN(term$)
            result$ = word$
        ELIF LEN(term$) = MaxLen THEN
            result$ = APPEND$(result$, 0, word$, NL$)
        END IF
    END IF
NEXT

PRINT result$


#lang racket
(define disjorder
  (match-lambda**
   (((list) n) '())
   ((m (list)) m)
   (((list h m-tail ...) (list h n-tail ...))
    (list* h (disjorder m-tail n-tail)))
   ;; the (not g/h) below stop greedy matching of the list which
   ;; would pick out orderings from the right first.
   (((list h (and (not g) m-tail-left) ... g m-tail-right ...)
     (list g (and (not h) n-tail-left) ... h n-tail-right ...))
    (disjorder `(,g ,@m-tail-left ,h ,@m-tail-right)
               `(,g ,@n-tail-left ,h ,@n-tail-right)))
   (((list h m-tail ...) n)
    (list* h (disjorder m-tail n)))))

(define (report-disjorder m n)
 (printf "Data M: ~a Order N: ~a -> ~a~%"
  (~a #:min-width 25 m) (~a #:min-width 10 n) (disjorder m n)))

;; Do the task tests
(report-disjorder '(the cat sat on the mat) '(mat cat))
(report-disjorder '(the cat sat on the mat) '(cat mat))
(report-disjorder '(A B C A B C A B C)      '(C A C A))
(report-disjorder '(A B C A B D A B E)      '(E A D A))
(report-disjorder '(A B)                    '(B))
(report-disjorder '(A B)                    '(B A))
(report-disjorder '(A B B A)                '(B A))
;; Do all of the other python tests
(report-disjorder '()            '())
(report-disjorder '(A)           '(A))
(report-disjorder '(A B)         '())
(report-disjorder '(A B B A)     '(A B))
(report-disjorder '(A B A B)     '(A B))
(report-disjorder '(A B A B)     '(B A B A))
(report-disjorder '(A B C C B A) '(A C A C))
(report-disjorder '(A B C C B A) '(C A C A))


sub order-disjoint-list-items(\M, \N) {
    my \bag = N.BagHash;
    M.map: { bag{$_}-- ?? N.shift !! $_ }
}

# Testing:

for q:to/---/.comb(/ [\S+]+ % ' ' /).map({[.words]})
    the cat sat on the mat      mat cat
    the cat sat on the mat      cat mat
    A B C A B C A B C           C A C A
    A B C A B D A B E           E A D A
    A B                         B
    A B                         B A
    A B B A                     B A
    X X Y                       X
    A X                         Y A
    ---
->  $m, $n { say "\n$m ==> $n\n", order-disjoint-list-items($m, $n) }


/*REXX program orders a  disjoint list  of   M   items  with a list of   N   items.     */
used = '0'x                                      /*indicates that a word has been parsed*/
 @.   =                                          /*placeholder indicates  end─of─array, */
 @.1  =   " the cat sat on the mat        |      mat cat  "                  /*a string.*/
 @.2  =   " the cat sat on the mat        |      cat mat  "                  /*"    "   */
 @.3  =   " A B C A B C A B C             |      C A C A  "                  /*"    "   */
 @.4  =   " A B C A B D A B E             |      E A D A  "                  /*"    "   */
 @.5  =   " A B                           |      B        "                  /*"    "   */
 @.6  =   " A B                           |      B A      "                  /*"    "   */
 @.7  =   " A B B A                       |      B A      "                  /*"    "   */
 @.8  =   "                               |               "                  /*"    "   */
 @.9  =   " A                             |      A        "                  /*"    "   */
 @.10 =   " A B                           |               "                  /*"    "   */
 @.11 =   " A B B A                       |      A B      "                  /*"    "   */
 @.12 =   " A B A B                       |      A B      "                  /*"    "   */
 @.13 =   " A B A B                       |      B A B A  "                  /*"    "   */
 @.14 =   " A B C C B A                   |      A C A C  "                  /*"    "   */
 @.15 =   " A B C C B A                   |      C A C A  "                  /*"    "   */
       /*  ════════════M═══════════             ════N════        */

  do j=1  while  @.j\==''                        /* [↓]  process each input string (@.).*/
  parse var  @.j    m   '|'   n                  /*parse input string into   M  and  N. */
  #= words(m)                                    /*#:   number of words in the  M  list.*/
               do i=#  for #  by -1              /*process list items in reverse order. */
               _= word(m, i);   !.i= _;   $._= i /*construct the   !.   and  $.  arrays.*/
               end   /*i*/
  r.=                                            /*nullify the replacement string  [R.] */
       do k=1  by 2  for words(n)%2              /* [↓]  process the  N  array.         */
       _= word(n, k);         v= word(n, k+1)    /*get an order word and the replacement*/
       p1= wordpos(_, m);     p2= wordpos(v, m)  /*positions of   "   "   "       "     */
       if p1==0 | p2==0  then iterate            /*if either not found, then skip them. */
       if $._>>$.v  then do;   r.p2= !.p1;    r.p1= !.p2;    end     /*switch the words.*/
                    else do;   r.p1= !.p1;    r.p2= !.p2;    end     /*don't switch.    */
       !.p1= used;    !.p2= used                                     /*mark 'em as used.*/
       m=
                         do i=1  for #;   m= m !.i;    _= word(m, i);    !.i= _;    $._= i
                         end   /*i*/
       end   /*k*/                               /* [↑]  rebuild the  !. and  $. arrays.*/
  mp=                                            /*the  MP  (aka M')  string  (so far). */
       do q=1  for #;    if !.q==used  then mp= mp  r.q              /*use the original.*/
                                       else mp= mp  !.q              /*use substitute.  */
       end   /*q*/                               /* [↑]  re─build the (output) string.  */

  say @.j   ' ────► '    space(mp)               /*display new re─ordered text ──► term.*/
  end        /*j*/                               /* [↑]  end of processing for  N  words*/
                                                 /*stick a fork in it,  we're all done. */


BEGIN # compare lists (rows) of integers #
    # returns TRUE if there is an element in a that is < the corresponding #
    # element in b and all previous elements are equal; FALSE otherwise    #
    OP < = ( []INT a, b )BOOL:
       IF  INT  a pos  := LWB a;
           INT  b pos  := LWB b;
           BOOL equal  := TRUE;
           WHILE a pos <= UPB a AND b pos <= UPB b AND equal DO
               equal := a[ a pos ] = b[ b pos ];
               IF equal THEN
                   a pos +:= 1;
                   b pos +:= 1
               FI
           OD;
           NOT equal
       THEN
           # there is an element in a and b that is not equal #
           a[ a pos ] < b[ b pos ]
       ELSE
           # all elements are equal or one list is shorter #
           # a is < b if a has fewer elements #
           a pos > UPB a AND b pos <= UPB b
       FI # < # ;

    # tests a < b has the expected result #
    PROC test = ( STRING a name, []INT a, STRING b name, []INT b, BOOL expected )VOID:
         BEGIN
            BOOL result = a < b;
            print( ( a name, IF result THEN " <  " ELSE " >= " FI, b name
                   , IF result = expected THEN "" ELSE ", NOT as expected" FI
                   , newline
                   )
                 )
         END # test # ;

    # test cases as in the BBC basic sample #
    []INT list1 = ( 1, 2, 1, 5, 2 );
    []INT list2 = ( 1, 2, 1, 5, 2, 2 );
    []INT list3 = ( 1, 2, 3, 4, 5 );
    []INT list4 = ( 1, 2, 3, 4, 5 );
    test( "list1", list1, "list2", list2, TRUE  );
    test( "list2", list2, "list3", list3, TRUE  );
    test( "list3", list3, "list4", list4, FALSE );

    # additional test cases #
    []INT list5 = ( 9, 0, 2, 1, 0 );
    []INT list6 = ( 4, 0, 7, 7 );
    []INT list7 = ( 4, 0, 7    );
    []INT list8 = ( );
    test( "list5", list5, "list6", list6, FALSE );
    test( "list6", list6, "list7", list7, FALSE );
    test( "list7", list7, "list8", list8, FALSE );
    test( "list8", list8, "list7", list7, TRUE  )

END


      dict% = OPENIN("unixdict.txt")
      IF dict%=0 ERROR 100, "Failed to open dictionary file"

      max% = 2
      REPEAT
        A$ = GET$#dict%
        IF LENA$ >= max% THEN
          i% = 0
          REPEAT i% += 1
          UNTIL ASCMID$(A$,i%) > ASCMID$(A$,i%+1)
          IF i% = LENA$ THEN
            IF i% > max% max% = i% : list$ = ""
            list$ += A$ + CHR$13 + CHR$10
          ENDIF
        ENDIF
      UNTIL EOF#dict%
      CLOSE #dict%
      PRINT list$
      END