// constants
constant EMX  = 64      // exponent maximum (if indexing starts at -EMX)
constant DMX  = 1e5     // approximation loop maximum
constant AMX  = 1048576 // argument maximum
constant PMAX = 32749   // prime maximum

// global variables
integer p1 = 0
integer p  = 7    // default prime
integer k  = 11   // precision

type Ratio(sequence r)
    return length(r)=2 and integer(r[1]) and integer(r[2])
end type

procedure pad_to(string fmt, sequence data, integer len)
    fmt = sprintf(fmt,data)
    puts(1,fmt&repeat(' ',len-length(fmt)))
end procedure

class Padic
    integer v = 0
    sequence d = repeat(0,EMX*2)

    // (re)initialize 'this' from Ratio, set 'sw' to print
    function r2pa(Ratio q, integer sw)
        integer {a,b} = q
        if b=0 then return 1 end if
        if b<0 then
            b = -b
            a = -a
        end if
        if abs(a)>AMX or b>AMX then return -1 end if
        if p<2 or k<1 then return 1 end if
        p = min(p, PMAX)  // maximum short prime
        k = min(k, EMX-1) // maximum array length
        if sw!=0 then
             -- numerator, denominator, prime, precision
            pad_to("%d/%d + O(%d^%d)",{a,b,p,k},30)
        end if

        // (re)initialize
        v = 0
        p1 = p - 1
        sequence ntd = repeat(0,2*EMX) -- (new this.d)
        if a=0 then return 0 end if

        // find -exponent of p in b
        integer i = 0
        while remainder(b,p)=0 do
            b /= p
            i -= 1
        end while
        integer s = 0,
                r = remainder(b,p)

        // modular inverse for small P
        integer b1 = 1
        while b1<=p1 do
            s += r
            if s>p1 then s -= p end if
            if s=1 then exit end if
            b1 += 1
        end while
        if b1=p then
            printf(1,"r2pa: impossible inverse mod")
            return -1
        end if
        v = EMX
        while true do
            // find exponent of P in a
            while remainder(a,p)=0 do
                a /= p
                i += 1
            end while

            // valuation
            if v=EMX then v = i end if

            // upper bound
            if i>=EMX then exit end if

            // check precision
            if i-v>k then exit end if

            // next digit
            integer rdx = remainder(a*b1,p)
            if rdx<0 then rdx += p end if
            if rdx<0 or rdx>=p then ?9/0 end if -- sanity chk
            ntd[i+EMX+1] = rdx

            // remainder - digit * divisor
            a -= rdx*b
            if a=0 then exit end if
        end while
        this.d = ntd
        return 0
    end function

    // Horner's rule
    function dsum()
        integer t = min(v, 0),
                s = 0
        for i=k-1+t to t by -1 do
            integer r = s
            s *= p
            if r!=0 and floor(s/r)-p!=0 then
                // overflow
                s = -1
                exit
            end if
            s += d[i+EMX+1]
        end for
        return s
    end function

    // add b to 'this'
    function add(Padic b)
        integer c = 0
        Padic r = new({min(v,b.v)})
        sequence rd = r.d
        for i=r.v to k+r.v do
            integer dx = i+EMX+1
            c += d[dx] + b.d[dx]
            if c>p1 then
                rd[dx] = c - p
                c = 1
            else
                rd[dx] = c
                c = 0
            end if
        end for
        r.d  = rd
        return r
    end function

    // complement
    function complement()
        integer c = 1
        Padic r = new({v})
        sequence rd = r.d
        for i=v to k+v do
            integer dx = i+EMX+1
            c += p1 - this.d[dx]
            if c>p1 then
                rd[dx] = c - p
                c = 1
            else
                rd[dx] = c
                c = 0
            end if
        end for
        r.d = rd
        return r
    end function

    // rational reconstruction
    procedure crat()
        integer sgn = 1
        Padic s = this
        integer j = 0,
                i = 1

        // denominator count
        while i<=DMX do
            // check for integer
            j = k-1+v
            while j>=v and s.d[j+EMX+1]=0 do
                j -= 1
            end while
            if ((j-v)*2)<k then exit end if

            // check for negative integer
            j = k-1+v
            while j>=v and p1-s.d[j+EMX+1]=0 do
                j -= 1
            end while
            if ((j-v)*2)<k then
                s = s.complement()
                sgn = -1
                exit
            end if

            // repeatedly add self to s
            s = s.add(this)
            i += 1
        end while

        // numerator: weighted digit sum
        integer x = s.dsum(),
                y = i
        if x<0 or y>DMX then
            printf(1,"crat: fail")
        else
            // negative powers
            for i=v to -1 do
                y *= p
            end for
            pad_to(iff(y=1?"%d":"%d/%d"),{x*sgn,y},26)
            printf(1,"+ = ")
        end if
    end procedure

    // print expansion
    procedure prntf(bool sw)
        integer t = min(v, 0)
        // rational approximation
        if sw!=0 then crat() end if
        for i=k-1+t to t by -1 do
            printf(1,"%d",d[i+EMX+1])
            printf(1,iff(i=0 and v<0?". ":" "))
        end for
        printf(1,"\n")
    end procedure
end class

sequence data = {
    /* rational reconstruction limits are relative to the precision */
    {{2, 1}, 2, 4, {1, 1}},
    {{4, 1}, 2, 4, {3, 1}},
    {{4, 1}, 2, 5, {3, 1}},
    {{4, 9}, 5, 4, {8, 9}},
-- all tested, but let's keep the output reasonable:
--  {{-7, 5}, 7, 4, {99, 70}},
--  {{26, 25}, 5, 4, {-109, 125}},
--  {{49, 2}, 7, 6, {-4851, 2}},
--  {{-9, 5}, 3, 8, {27, 7}},
--  {{5, 19}, 2, 12, {-101, 384}},
--  /* four decadic pairs */
--  {{6, 7}, 10, 7, {-5, 7}},
--  {{2, 7}, 10, 7, {-3, 7}},
--  {{2, 7}, 10, 7, {-1, 7}},
--  {{34, 21}, 10, 9, {-39034, 791}},
--  /* familiar digits */
--  {{11, 4}, 2, 43, {679001, 207}},
--  {{11, 4}, 3, 27, {679001, 207}},
--  {{11, 4}, 11, 13, {679001, 207}},
--  {{-22, 7}, 2, 37, {46071, 379}},
--  {{-22, 7}, 3, 23, {46071, 379}},
--  {{-22, 7}, 7, 13, {46071, 379}},
--  {{-101, 109}, 2, 40, {583376, 6649}},
--  {{-101, 109}, 61, 7, {583376, 6649}},
--  {{-101, 109}, 32749, 3, {583376, 6649}},
--  {{-25, 26}, 7, 13, {5571, 137}},
--  {{1, 4}, 7, 11, {9263, 2837}},
--  {{122, 407}, 7, 11, {-517, 1477}},
    /* more subtle */
    {{5, 8}, 7, 11, {353, 30809}}
}

integer sw = 0,qa,qb
Padic a = new()
Padic b = new()

for i=1 to length(data) do
    {Ratio q, p, k, Ratio q2} = data[i]
    sw = a.r2pa(q, 1)
    if sw=1 then exit end if
    a.prntf(0)
    sw = sw or b.r2pa(q2, 1)
    if sw=1 then exit end if
    if sw=0 then
        b.prntf(0)
        Padic c = a.add(b)
        c.prntf(1)
    end if
    printf(1,"\n")
end for


import "/dynamic" for Struct

// constants
var EMX  = 64       // exponent maximum (if indexing starts at -EMX)
var DMX  = 1e5      // approximation loop maximum
var AMX  = 1048576  // argument maximum
var PMAX = 32749    // prime maximum

// global variables
var P1 = 0
var P  = 7    // default prime
var K  = 11   // precision

var Ratio = Struct.create("Ratio", ["a", "b"])

class Padic {
    // uninitialized
    construct new() {
        _v = 0
        _d = List.filled(2 * EMX, 0) // add EMX to index to be consistent wih FB
    }

    // properties
    v { _v }
    v=(o) { _v = o }
    d { _d }

    // (re)initialize 'this' from Ratio, set 'sw' to print
    r2pa(q, sw) {
        var a = q.a
        var b = q.b
        if (b == 0) return 1
        if (b < 0) {
            b = -b
            a = -a
        }
        if (a.abs > AMX || b > AMX) return -1
        if (P < 2 || K < 1) return 1
        P = P.min(PMAX)  // maximum short prime
        K = K.min(EMX-1) // maximum array length
        if (sw != 0) {
            System.write("%(a)/%(b) + ")  // numerator, denominator
            System.print("0(%(P)^%(K))")   // prime, precision
        }

        // (re)initialize
        _v = 0
        P1 = P - 1
        _d = List.filled(2 * EMX, 0)
        if (a == 0) return 0
        var i = 0
        // find -exponent of P in b
        while (b%P == 0) {
            b = (b/P).truncate
            i = i - 1
        }
        var s = 0
        var r = b % P

        // modular inverse for small P
        var b1 = 1
        while (b1 <= P1) {
            s = s + r
            if (s > P1) s = s - P
            if (s == 1) break
            b1 = b1 + 1
        }
        if (b1 == P) {
            System.print("r2pa: impossible inverse mod")
            return -1
        }
        _v = EMX
        while (true) {
            // find exponent of P in a
            while (a%P == 0) {
                a = (a/P).truncate
                i = i + 1
            }

            // valuation
            if (_v == EMX) _v = i

            // upper bound
            if (i >= EMX) break

            // check precision
            if ((i - _v) > K) break

            // next digit
            _d[i+EMX] = a * b1 % P
            if (_d[i+EMX] < 0) _d[i+EMX] = _d[i+EMX] + P

            // remainder - digit * divisor
            a = a - _d[i+EMX]*b
            if (a == 0) break
        }
        return 0
    }

    // Horner's rule
    dsum() {
        var t = _v.min(0)
        var s = 0
        for (i in K - 1 + t..t) {
            var r = s
            s = s * P
            if (r != 0 && ((s/r).truncate - P) != 0) {
                // overflow
                s = -1
                break
            }
            s = s + _d[i+EMX]
        }
        return s
    }

    // rational reconstruction
    crat() {
        var fl = false
        var s = this
        var j = 0
        var i = 1

        // denominator count
        while (i <= DMX) {
            // check for integer
            j = K - 1 + _v
            while (j >= _v) {
                if (s.d[j+EMX] != 0) break
                j = j - 1
            }
            fl = ((j - _v) * 2) < K
            if (fl) {
                fl = false
                break
            }

            // check negative integer
            j = K - 1 + _v
            while (j >= _v) {
                if (P1 - s.d[j+EMX] != 0) break
                j = j - 1
            }
            fl = ((j - _v) * 2) < K
            if (fl) break

            // repeatedly add self to s
            s = s + this
            i = i + 1
        }
        if (fl) s = s.cmpt

        // numerator: weighted digit sum
        var x = s.dsum()
        var y = i
        if (x < 0 || y > DMX) {
            System.print("crat: fail")
        } else {
            // negative powers
            i = _v
            while (i <= -1) {
                y = y * P
                i = i + 1
            }

            // negative rational
            if (fl) x = -x
            System.write(x)
            if (y > 1) System.write("/%(y)")
            System.print()
        }
    }

    // print expansion
    printf(sw) {
        var t = _v.min(0)
        for (i in K - 1 + t..t) {
            System.write(_d[i + EMX])
            if (i == 0 && _v < 0) System.write(".")
            System.write(" ")
        }
        System.print()
        // rational approximation
        if (sw != 0) crat()
    }

    // add b to 'this'
    +(b) {
        var c = 0
        var r = Padic.new()
        r.v = _v.min(b.v)
        for (i in r.v..K + r.v) {
            c = c + _d[i+EMX] + b.d[i+EMX]
            if (c > P1) {
                r.d[i+EMX] = c - P
                c = 1
            } else {
                r.d[i+EMX] = c
                c = 0
            }
        }
        return r
    }

    // complement
    cmpt {
        var c = 1
        var r = Padic.new()
        r.v = _v
        for (i in _v..K + _v) {
            c = c + P1 - _d[i+EMX]
            if (c > P1) {
                r.d[i+EMX] = c - P
                c = 1
            } else {
                r.d[i+EMX] = c
                c = 0
            }
        }
        return r
    }
}

var data = [
    /* rational reconstruction depends on the precision
       until the dsum-loop overflows */
    [2, 1, 2, 4, 1, 1],
    [4, 1, 2, 4, 3, 1],
    [4, 1, 2, 5, 3, 1],
    [4, 9, 5, 4, 8, 9],
    [26, 25, 5, 4, -109, 125],
    [49, 2, 7, 6, -4851, 2],
    [-9, 5, 3, 8, 27, 7],
    [5, 19, 2, 12, -101, 384],
    /* two decadic pairs */
    [2, 7, 10, 7, -1, 7],
    [34, 21, 10, 9, -39034, 791],
    /* familiar digits */
    [11, 4, 2, 43, 679001, 207],
    [-8, 9, 23, 9, 302113, 92],
    [-22, 7, 3, 23, 46071, 379],
    [-22, 7, 32749, 3, 46071, 379],
    [35, 61, 5, 20, 9400, 109],
    [-101, 109, 61, 7, 583376, 6649],
    [-25, 26, 7, 13, 5571, 137],
    [1, 4, 7, 11, 9263, 2837],
    [122, 407, 7, 11, -517, 1477],
    /* more subtle */
    [5, 8, 7, 11, 353, 30809]
]

var sw = 0
var a = Padic.new()
var b = Padic.new()

for (d in data) {
    var q = Ratio.new(d[0], d[1])
    P = d[2]
    K = d[3]
    sw = a.r2pa(q, 1)
    if (sw == 1) break
    a.printf(0)
    q.a = d[4]
    q.b = d[5]
    sw = sw | b.r2pa(q, 1)
    if (sw == 1) break
    if (sw == 0) {
        b.printf(0)
        var c = a + b
        System.print("+ =")
        c.printf(1)
    }
    System.print()
}


F is_palindrome(s)
   R s == reversed(s)


*        Reverse b string          25/06/2018
PALINDRO CSECT
         USING  PALINDRO,R13       base register
         B      72(R15)            skip savearea
         DC     17F'0'             savearea
         STM    R14,R12,12(R13)    prolog
         ST     R13,4(R15)         "
         ST     R15,8(R13)         "
         LR     R13,R15            "
         LA     R8,BB              @b[1]
         LA     R9,AA+L'AA-1       @a[n-1]
         LA     R6,1               i=1
LOOPI    C      R6,=A(L'AA)        do i=1 to length(a)
         BH     ELOOPI             leave i
         MVC    0(1,R8),0(R9)        substr(b,i,1)=substr(a,n-i+1,1)
         LA     R8,1(R8)             @[email protected]+1
         BCTR   R9,0                 @[email protected]
         LA     R6,1(R6)             i=i+1
         B      LOOPI              end do
ELOOPI   XPRNT  AA,L'AA            print a
         CLC    BB,AA              if b=a
         BNE    SKIP
         XPRNT  MSG,L'MSG          then print msg
SKIP     L      R13,4(0,R13)       epilog
         LM     R14,R12,12(R13)    "
         XR     R15,R15            "
         BR     R14                exit
AA       DC     CL32'INGIRUMIMUSNOCTEETCONSUMIMURIGNI'  a
BB       DS     CL(L'AA)           b
MSG      DC     CL23'IT IS A TRUE PALINDROME'
         YREGS
         END    PALINDRO


	org	100h
	jmp	demo
	;;;	Is the $-terminated string at DE a palindrome?
	;;;	Returns: zero flag set if palindrome
palin:	mov	h,d	; Find end of string
	mov	l,e
	mvi	a,'$'
	cmp	m	; The empty string is a palindrome
	rz
pend:	inx	h	; Scan until terminator found
	cmp	m
	jnz	pend
	dcx	h	; Move to last byte of text
ptest:	ldax	d	; Load char at left pointer
	cmp 	m	; Compare to char at right pointer
	rnz		; If not equal, not a palindrome
	inx	d	; Move pointers
	dcx	h
	mov	a,d	; Check if left pointer is before right pointer
	cmp 	h	; High byte
	jc	ptest
	mov	a,e	; Low byte
	cmp	l
	jc	ptest
	xra	a	; Made it to the end - set zero flag
	ret		; Return
	;;;	Test the routine on a few examples
demo:	lxi	h,words	; Word list pointer
loop:	mov	e,m	; Load word pointer
	inx	h
	mov	d,m
	inx	h
	mov	a,e	; Stop when zero reached
	ora	d
	rz
	push	h	; Keep word list pointer
	call	pstr	; Print word
	call	palin	; Check if palindrome
	lxi	d,no
	jnz 	print	; Print "no" if not a palindrome
	lxi	d,yes	; Print "yes" otherwise
print:	call	pstr
	pop	h
	jmp 	loop
	;;;	Print strint using CP/M keeping DEHL registers
pstr:	push	d
	push	h
	mvi	c,9
	call	5
	pop	h
	pop	d
	ret
yes:	db	': yes',13,10,'$'
no:	db	': no',13,10,'$'
words:	dw	w1,w2,w3,w4,0
w1:	db	'rotor$'
w2:	db	'racecar$'
w3:	db	'level$'
w4:	db	'rosetta$'


	cpu	8086
	org	100h
section	.text
	jmp	demo
	;;;	Check if the $-terminated string in [DS:SI] is a palindrome.
	;;;	Returns with zero flag set if so.
	;;;	Destroyed: AL, CX, SI, DI, ES.
palin:	push	es		; Set ES=DS.
	pop	ds
	mov	al,'$'		; Find end of string
	mov	cx,-1
	mov	di,si
	repne	scasb
	dec	di		; Move back to last actual character
.loop:	cmp	si,di
	ja	.ok		; If SI > DI, it is a palindrome
	lodsb
	dec	di		; Compare left character to right character
	cmp	al,[di]
	jne	.no		; If not equal, not a palindrome
	jmp 	.loop		; Otherwise, try next pair of characters
.ok:	cmp	al,al		; Set zero flag
.no: 	ret 			; Return
	;;;	Try the routine on a couple of strings
demo:	mov	si,words
.loop:	lodsw			; Grab word pointer
	test	ax,ax		; Zero?
	jz	.done		; Then we are done
	mov	dx,ax		; Otherwise, print word
	mov	ah,9
	int	21h
	xchg	bp,si		; Keep array pointer in BP
	xchg	si,dx		; Put word pointer in SI
	call	palin		; Check if it is a palindrome
	mov	dx,yes		; Print 'yes'...
	jz	.print		; ...if it is a palindrome
	mov	dx,no		; Otherwise, print 'no'
.print:	int 	21h
	xchg	si,bp		; Restore array pointer
	jmp	.loop		; Get next word.
.done:	ret
yes:	db	': yes',13,10,'$'	; Yes and no
no:	db	': no',13,10,'$'
words:	dw	.w1,.w2,.w3,.w4,.w5,0
.w1:	db	'rotor$'	; Words to check
.w2:	db	'racecar$'
.w3:	db	'level$'
.w4:	db	'redder$'
.w5:	db	'rosetta$'


(defun reverse-split-at-r (xs i ys)
  (if (zp i)
      (mv xs ys)
      (reverse-split-at-r (rest xs) (1- i)
                          (cons (first xs) ys))))

(defun reverse-split-at (xs i)
  (reverse-split-at-r xs i nil))

(defun is-palindrome (str)
  (let* ((lngth (length str))
         (idx (floor lngth 2)))
    (mv-let (xs ys)
            (reverse-split-at (coerce str 'list) idx)
            (if (= (mod lngth 2) 1)
                (equal (rest xs) ys)
                (equal xs ys)))))


BYTE FUNC Palindrome(CHAR ARRAY s)
  BYTE l,r

  l=1 r=s(0)
  WHILE l<r
  DO
    IF s(l)#s(r) THEN RETURN (0) FI
    l==+1 r==-1
  OD
RETURN (1)

BYTE FUNC IsIgnored(BYTE c)
  IF (c>='  AND c<='/) OR
     (c>=': AND c<='@) OR
     (c>='[ AND c<='_) THEN
    RETURN (1)
  FI
RETURN (0)

BYTE FUNC ToUpper(BYTE c)
  IF c>='a AND c<='z THEN
    RETURN (c-'a+'A)
  FI
RETURN (c)

BYTE FUNC InexactPalindrome(CHAR ARRAY s)
  BYTE l,r,lc,rc

  l=1 r=s(0)
  WHILE l<r
  DO
    WHILE IsIgnored(s(l))
    DO
      l==+1
      IF l>=r THEN RETURN (1) FI
    OD
    WHILE IsIgnored(s(r))
    DO
      r==-1
      IF l>=r THEN RETURN (1) FI
    OD

    lc=ToUpper(s(l))
    rc=ToUpper(s(r))

    IF lc#rc THEN RETURN (0) FI
    l==+1 r==-1
  OD
RETURN (1)

PROC Test(CHAR ARRAY s)
  IF Palindrome(s) THEN
    PrintF("'%S' is a palindrome%E%E",s)
  ELSEIF InexactPalindrome(s) THEN
    PrintF("'%S' is an inexact palindrome%E%E",s)
  ELSE
    PrintF("'%S' is not a palindrome%E%E",s)
  FI
RETURN

PROC Main()
  Test("rotavator")
  Test("13231+464+989=989+464+13231")
  Test("Was it a car or a cat I saw?")
  Test("Did Hannah see bees? Hannah did.")
  Test("This sentence is not a palindrome.")
  Test("123 456 789 897 654 321")
RETURN


function isPalindrome(str:String):Boolean
{
	for(var first:uint = 0, second:uint = str.length - 1; first < second; first++, second--)
		if(str.charAt(first) != str.charAt(second)) return false;
	return true;
}


function Palindrome (Text : String) return Boolean is
begin
   for Offset in 0..Text'Length / 2 - 1 loop
      if Text (Text'First + Offset) /= Text (Text'Last - Offset) then
         return False;
      end if;
   end loop;
   return True;
end Palindrome;


# Iterative #
PROC palindrome = (STRING s)BOOL:(
   FOR i TO UPB s OVER 2 DO
     IF s[i] /= s[UPB s-i+1] THEN GO TO return false FI
   OD;Power
   else: TRUE EXIT
   return false: FALSE
);

# Recursive #
PROC palindrome r = (STRING s)BOOL:
   IF LWB s >= UPB s THEN TRUE
   ELIF s[LWB s] /= s[UPB s] THEN FALSE
   ELSE palindrome r(s[LWB s+1:UPB s-1])
   FI
;

# Test #
main:
(
   STRING t = "ingirumimusnocteetconsumimurigni";
   FORMAT template = $"sequence """g""" "b("is","isnt")" a palindrome"l$;

   printf((template, t, palindrome(t)));
   printf((template, t, palindrome r(t)))
)


      {⍵≡⌽⍵} 'abc'
0
      {⍵≡⌽⍵} '⍋racecar⍋'
1


use framework "Foundation"

------ CASE-INSENSITIVE PALINDROME, IGNORING SPACES ? ----

-- isPalindrome :: String -> Bool
on isPalindrome(s)
    s = intercalate("", reverse of characters of s)
end isPalindrome

-- toSpaceFreeLower :: String -> String
on spaceFreeToLower(s)
    script notSpace
        on |λ|(s)
            s is not space
        end |λ|
    end script

    intercalate("", filter(notSpace, characters of toLower(s)))
end spaceFreeToLower

--------------------------- TEST -------------------------
on run

    isPalindrome(spaceFreeToLower("In girum imus nocte et consumimur igni"))

    --> true

end run

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

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

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

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

-- toLower :: String -> String
on toLower(str)
    set ca to current application
    ((ca's NSString's stringWithString:(str))'s ¬
        lowercaseStringWithLocale:(ca's NSLocale's currentLocale())) as text
end toLower


100 DATA"MY DOG HAS FLEAS"
110 DATA"MADAM, I'M ADAM."
120 DATA"1 ON 1"
130 DATA"IN GIRUM IMUS NOCTE ET CONSUMIMUR IGNI"
140 DATA"A man, a plan, a canal: Panama!"
150 DATA"KAYAK"
160 DATA"REDDER"
170 DATA"H"
180 DATA""

200 FOR L1 = 1 TO 9
210    READ W$ : GOSUB 300" IS PALINDROME?
220    PRINT CHR$(34); W$; CHR$(34); " IS ";
230    IF NOT PALINDROME THEN PRINT "NOT ";
240    PRINT "A PALINDROME"
250 NEXT
260 END

300 REMIS PALINDROME?
310 PA = 1
320 L = LEN(W$)
330 IF L = 0 THEN RETURN
340 FOR L0 = 1 TO L / 2 + .5
350     PA = MID$(W$, L0, 1) = MID$(W$, L - L0 + 1, 1)
360     IF PALINDROME THEN NEXT L0
370 RETURN


@ Check whether the ASCII string in [r0] is a palindrome
@ Returns with zero flag set if palindrome.
palin:	mov	r1,r0		@ Find end of string
1:	ldrb	r2,[r1],#1	@ Grab character and increment pointer
	tst	r2,r2		@ Zero yet?
	bne	1b		@ If not try next byte
	sub	r1,r1,#2	@ Move R1 to last actual character.
2:	cmp	r0,r1		@ When R0 >= R1,
	cmpgt	r2,r2		@ make sure zero is set,
	bxeq	lr		@ and stop (the string is a palindrome).
	ldrb	r2,[r1],#-1	@ Grab [R1] (end) and decrement.
	ldrb	r3,[r0],#1	@ Grab [R0] (begin) and increment
	cmp	r2,r3		@ Are they equal?
	bxne	lr		@ If not, it's not a palindrome.
	b	2b		@ Otherwise, try next pair.

@ Try the function on a couple of strings
.global _start
_start:	ldr	r8,=words	@ Word pointer
1:	ldr	r9,[r8],#4	@ Grab word and move pointer
	tst	r9,r9		@ Null?
	moveq	r7,#1		@ Then we're done; syscall 1 = exit
	swieq	#0
	mov	r1,r9		@ Print the word
	bl	print
	mov	r0,r9		@ Test if the word is a palindrome
	bl	palin
	ldreq	r1,=yes		@ "Yes" if it is a palindrome
	ldrne	r1,=no		@ "No" if it's not a palindrome
	bl	print
	b	1b		@ Next word

@ Print zero-terminated string [r1] using Linux syscall
print:	push	{r7,lr}		@ Keep R7 and link register
	mov	r2,r1		@ Find end of string
1:	ldrb	r0,[r2],#1	@ Grab character and increment pointer
	tst	r0,r0		@ Zero yet?
	bne	1b		@ If not, keep going
	sub	r2,r2,r1	@ Calculate length of string (bytes to write)
	mov	r0,#1		@ Stdout = 1
	mov	r7,#4		@ Syscall 4 = write
	swi	#0		@ Make the syscall
	pop	{r7,lr}		@ Restore R7 and link register
	bx	lr

@ Strings
yes:	.asciz	": yes\n"	@ Output yes or no
no:	.asciz	": no\n"
w1:	.asciz	"rotor"		@ Words to test
w2:	.asciz	"racecar"
w3:	.asciz	"level"
w4:	.asciz	"redder"
w5:	.asciz	"rosetta"
words:	.word	w1,w2,w3,w4,w5,0


palindrome?: $[seq] -> seq = reverse seq

loop ["abba" "boom" "radar" "civic" "great"] 'wrd [
	print [wrd ": palindrome?" palindrome? wrd]
]


IsPalindrome(Str){
	Loop, Parse, Str
		ReversedStr := A_LoopField . ReversedStr
	return, (ReversedStr == Str)?"Exact":(RegExReplace(ReversedStr,"\W")=RegExReplace(Str,"\W"))?"Inexact":"False"
}


;== AutoIt Version: 3.3.8.1

Global $aString[7] = [ _
"In girum imus nocte, et consumimur igni", _  ; inexact palindrome
"Madam, I'm Adam.", _                         ; inexact palindrome
"salàlas", _                                  ; exact palindrome
"radar", _                                    ; exact palindrome
"Lagerregal", _                               ; exact palindrome
"Ein Neger mit Gazelle zagt im Regen nie.", _ ; inexact palindrome
"something wrong"]                            ; no palindrome
Global $sSpace42 = "                                          "

For $i = 0 To 6
	If _IsPalindrome($aString[$i]) Then
		ConsoleWrite('"' & $aString[$i] & '"' & StringLeft($sSpace42, 42-StringLen($aString[$i])) & 'is an exact palindrome.' & @LF)
	Else
		If _IsPalindrome( StringRegExpReplace($aString[$i], '\W', '') ) Then
			ConsoleWrite('"' & $aString[$i] & '"' & StringLeft($sSpace42, 42-StringLen($aString[$i])) & 'is an  inexact palindrome.' & @LF)
		Else
			ConsoleWrite('"' & $aString[$i] & '"' & StringLeft($sSpace42, 42-StringLen($aString[$i])) & 'is not a palindrome.' & @LF)
		EndIf
	EndIf
Next

Func _IsPalindrome($_string)
	Local $iLen = StringLen($_string)
	For $i = 1  To Int($iLen/2)
		If StringMid($_string, $i, 1) <> StringMid($_string, $iLen-($i-1), 1) Then Return False
	Next
	Return True
EndFunc


function is_palindro(s)
{
  if ( s == reverse(s) ) return 1
  return 0
}


OPTION COMPARE TRUE

INPUT "Enter your line... ", word$

IF word$ = REVERSE$(word$) THEN
    PRINT "This is an exact palindrome!"
ELIF EXTRACT$(word$, "[[:punct:]]|[[:blank:]]", TRUE) = REVERSE$(EXTRACT$(word$, "[[:punct:]]|[[:blank:]]", TRUE)) THEN
    PRINT "This is an inexact palindrome!"
ELSE
    PRINT "Not a palindrome."
ENDIF


F user_cmp(String a, b)
   R Int(input(‘IS #6 <, ==, or > #6  answer -1, 0 or 1:’.format(a, b)))

V items = ‘violet red green indigo blue yellow orange’.split(‘ ’)
V ans = sorted(items, key' cmp_to_key(user_cmp))
print("\n"ans.join(‘ ’))


#! /bin/bash
# very simple way to detect a palindrome in Bash
# output of bash --version -> GNU bash, version 4.4.7(1)-release x86_64 ...

echo "enter a string"
read input

size=${#input}
count=0

while (($count < $size))
do
    array[$count]=${input:$count:1}
    (( count+=1 ))
done

count=0

for ((i=0 ; i < $size; i+=1))
do
    if [ "${array[$i]}" == "${array[$size - $i - 1]}" ]
    then
        (( count += 1 ))
    fi
done

if (( $count == $size ))
then
    echo "$input is a palindrome"
fi


' OPTION _EXPLICIT ' For QB64. In VB-DOS remove the underscore.

DIM txt$

' Palindrome
CLS
PRINT "This is a palindrome detector program."
PRINT
INPUT "Please, type a word or phrase: ", txt$

IF IsPalindrome(txt$) THEN
  PRINT "Is a palindrome."
ELSE
  PRINT "Is Not a palindrome."
END IF

END

FUNCTION IsPalindrome (AText$)
  ' Var
  DIM CleanTXT$, RvrsTXT$

  CleanTXT$ = CleanText$(AText$)
  RvrsTXT$ = RvrsText$(CleanTXT$)

  IsPalindrome = (CleanTXT$ = RvrsTXT$)

END FUNCTION

FUNCTION CleanText$ (WhichText$)
  ' Var
  DIM i%, j%, c$, NewText$, CpyTxt$, AddIt%, SubsTXT$
  CONST False = 0, True = NOT False

  SubsTXT$ = "AIOUE"
  CpyTxt$ = UCASE$(WhichText$)
  j% = LEN(CpyTxt$)

  FOR i% = 1 TO j%
    c$ = MID$(CpyTxt$, i%, 1)

    ' See if it is a letter. Includes Spanish letters.
    SELECT CASE c$
      CASE "A" TO "Z"
        AddIt% = True
      CASE " ", "¡", "¢", "£"
        c$ = MID$(SubsTXT$, ASC(c$) - 159, 1)
        AddIt% = True
      CASE "‚"
        c$ = "E"
        AddIt% = True
      CASE "¤"
        c$ = "¥"
        AddIt% = True
      CASE ELSE
        AddIt% = False
    END SELECT

    IF AddIt% THEN
      NewText$ = NewText$ + c$
    END IF
  NEXT i%

  CleanText$ = NewText$

END FUNCTION

FUNCTION RvrsText$ (WhichText$)
  ' Var
  DIM i%, c$, NewText$, j%

  j% = LEN(WhichText$)
  FOR i% = 1 TO j%
    NewText$ = MID$(WhichText$, i%, 1) + NewText$
  NEXT i%

  RvrsText$ = NewText$

END FUNCTION


DEFINE PTR="CARD"

PROC PrintArray(PTR ARRAY a BYTE size)
  BYTE i

  Put('[)
  FOR i=0 TO size-1
  DO
    IF i>0 THEN Put(' ) FI
    Print(a(i))
  OD
  Put(']) PutE()
RETURN

BYTE FUNC IsBefore(CHAR ARRAY a,b)
  DEFINE NO_KEY="255"
  DEFINE KEY_Y="43"
  DEFINE KEY_N="35"
  BYTE CH=$02FC ;Internal hardware value for last key pressed
  BYTE k

  PrintF("Is %S before %S (y/n)? ",a,b)
  CH=NO_KEY ;Flush the keyboard
  DO
    k=CH
  UNTIL k=KEY_Y OR k=KEY_N
  OD
  CH=NO_KEY ;Flush the keyboard
  IF k=KEY_Y THEN
    PrintE("yes")
    RETURN (1)
  FI
  PrintE("no")
RETURN (0)

PROC InteractiveInsertionSort(PTR ARRAY a BYTE size)
  INT i,j
  PTR value

  FOR i=1 TO size-1
  DO
    value=a(i)
    j=i-1
    WHILE j>=0 AND IsBefore(value,a(j))=1
    DO
      a(j+1)=a(j)
      j==-1
    OD
    a(j+1)=value
  OD
RETURN

PROC Main()
  DEFINE COUNT="7"
  PTR ARRAY arr(COUNT)

  arr(0)="violet" arr(1)="red"
  arr(2)="green"  arr(3)="indigo"
  arr(4)="blue"   arr(5)="yellow"
  arr(6)="orange"

  Print("Shuffled array: ")
  PrintArray(arr,COUNT) PutE()

  InteractiveInsertionSort(arr,COUNT)
  PutE() Print("Sorted array: ")
  PrintArray(arr,COUNT)
RETURN


lst: ["violet" "red" "green" "indigo" "blue" "yellow" "orange"]
count: 0

findSpot: function [l,e][
    if empty? l -> return 0

    loop.with:'i l 'item [
        answer: input ~"Is |item| greater than |e| [y/n]? "
        if answer="y" -> return i
    ]
    return dec size l
]

sortedLst: new []

loop lst 'element ->
    insert 'sortedLst findSpot sortedLst element element

print ""
print ["sorted =>" sortedLst]


data := ["Violet", "Red", "Green", "Indigo", "Blue", "Yellow", "Orange"]
result := [], num := 0, Questions :=""

for i, Color1 in data{
    found :=false
    if !result.count(){
        result.Push(Color1)
        continue
    }

    for j, Color2 in result	{
        if (color1 = color2)
            continue
        MsgBox, 262180,, % (Q := "Q" ++num " is " Color1 " > " Color2 "?")
        ifMsgBox, Yes
            Questions .= Q "`t`tYES`n"
        else {
            Questions .= Q "`t`tNO`n"
            result.InsertAt(j, Color1)
            found := true
            break
        }
    }
    if !found
        result.Push(Color1)
}
for i, color in result
    output .= color ", "
MsgBox % Questions "`nSorted Output :`n" Trim(output, ", ")
return


#include <stdio.h>
#include <string.h>
#include <stdlib.h>

int interactiveCompare(const void *x1, const void *x2)
{
  const char *s1 = *(const char * const *)x1;
  const char *s2 = *(const char * const *)x2;
  static int count = 0;
  printf("(%d) Is %s <, ==, or > %s? Answer -1, 0, or 1: ", ++count, s1, s2);
  int response;
  scanf("%d", &response);
  return response;
}

void printOrder(const char *items[], int len)
{
  printf("{ ");
  for (int i = 0; i < len; ++i) printf("%s ", items[i]);
  printf("}\n");
}

int main(void)
{
  const char *items[] =
    {
      "violet", "red", "green", "indigo", "blue", "yellow", "orange"
    };

  qsort(items, sizeof(items)/sizeof(*items), sizeof(*items), interactiveCompare);
  printOrder(items, sizeof(items)/sizeof(*items));
  return 0;
}


@echo off
setlocal enabledelayedexpansion
set /p string=Your string :
set count=0
:loop
	if "!%string%:~%count%,1!" neq "" (
		set reverse=!%string%:~%count%,1!!reverse!
		set /a count+=1
		goto loop
	)
set palindrome=isn't
if "%string%"=="%reverse%" set palindrome=is
echo %string% %palindrome% a palindrome.
pause
exit


get "libhdr"

let palindrome(s) = valof
$(  let l = s%0
    for i = 1 to l/2
        unless s%i = s%(l+1-i)
            resultis false
    resultis true
$)

let inexact(s) = valof
$(  let temp = vec 1+256/BYTESPERWORD
    temp%0 := 0
    for i = 1 to s%0 do
    $(  let ch = s%i | 32
        if '0'<=ch & ch<='9' | 'a'<=ch & ch<='z' then
        $(  temp%0 := temp%0 + 1
            temp%(temp%0) := ch
        $)
    $)
    resultis palindrome(temp)
$)

let check(s) =
    palindrome(s) -> "exact palindrome",
    inexact(s) -> "inexact palindrome",
    "not a palindrome"

let start() be
$(  let tests = vec 8
    tests!0 := "rotor"
    tests!1 := "racecar"
    tests!2 := "RACEcar"
    tests!3 := "level"
    tests!4 := "redder"
    tests!5 := "rosetta"
    tests!6 := "A man, a plan, a canal: Panama"
    tests!7 := "Egad, a base tone denotes a bad age"
    tests!8 := "This is not a palindrome"

    for i = 0 to 8 do
        writef("'%S': %S*N", tests!i, check(tests!i))
$)


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

using namespace std;

bool InteractiveCompare(const string& s1, const string& s2)
{
    if(s1 == s2) return false;  // don't ask to compare items that are the same
    static int count = 0;
    string response;
    cout << "(" << ++count << ") Is " << s1 << " < " << s2 << "? ";
    getline(cin, response);
    return !response.empty() && response.front() == 'y';
}

void PrintOrder(const vector<string>& items)
{
    cout << "{ ";
    for(auto& item : items) cout << item << " ";
    cout << "}\n";
}

int main()
{
    const vector<string> items
    {
        "violet", "red", "green", "indigo", "blue", "yellow", "orange"
    };

    vector<string> sortedItems;

    // Use a binary insertion sort to order the items.  It should ask for
    // close to the minimum number of questions required
    for(auto& item : items)
    {
        cout << "Inserting '" << item << "' into ";
        PrintOrder(sortedItems);
        // lower_bound performs the binary search using InteractiveCompare to
        // rank the items
        auto spotToInsert = lower_bound(sortedItems.begin(),
                                        sortedItems.end(), item, InteractiveCompare);
        sortedItems.insert(spotToInsert, item);
    }
    PrintOrder(sortedItems);
    return 0;
}


100 REM SORT BY COMPARISON
110 DIM IN$(6), OU$(6)
120 FOR I=0 TO 6:READ IN$(I): NEXT I
130 DATA VIOLET,RED,GREEN,INDIGO,BLUE,YELLOW,ORANGE
140 OU$(0)=IN$(0):N=1
150 FOR I=1 TO 6
160 : IN$=IN$(I)
180 : GOSUB 390
190 : FOR J=0 TO N-1
200 :  OU$ = OU$(J)
210 :  GOSUB 340
220 :  IF R>=0 THEN 280
230 :  FOR K=N TO J+1 STEP -1
240 :   OU$(K) = OU$(K-1)
250 :  NEXT K
260 :  OU$(J) = IN$
270 :  GOTO 300
280 : NEXT J
290 : OU$(N) = IN$
300 : N=N+1
310 NEXT I
320 GOSUB 390
330 END
340 PRINT "IS "IN$" < "OU$"? (Y/N)";
350 GET K$: IF K$<>"Y" AND K$<>"N" THEN 350
360 PRINT K$
370 R = K$="Y"
380 RETURN
390 PRINT "(";
400 IF N=1 THEN 420
410 FOR Q=0 TO N-2:PRINT OU$(Q)",";:NEXT Q
420 PRINT OU$(N-1)")"
430 RETURN


// Order by pair comparisons. Nigel Galloway: April 23rd., 2021
let clrs=let n=System.Random() in lN2p [|for g in 7..-1..2->n.Next(g)|] [|"Red";"Orange";"Yellow";"Green";"Blue";"Indigo";"Violet"|]
let rec fG n g=printfn "Is %s less than %s" n g; match System.Console.ReadLine() with "Yes"-> -1|"No"->1 |_->printfn "Enter Yes or No"; fG n g
let mutable z=0 in printfn "%A sorted to %A using %d questions" clrs (clrs|>Array.sortWith(fun n g->z<-z+1; fG n g)) z


Pal ← ≡⊸⌽
Pal1 ← ⊢≡⌽
Pal2 ← {𝕩≡⌽𝕩}


USING: formatting io kernel math.order prettyprint qw sorting ;

qw{ violet red green indigo blue yellow orange }
[ "Is %s > %s? (y/n) " printf readln "y" = +gt+ +lt+ ? ] sort .


Dim Shared As Byte r, n = 1
Dim Shared As String IN1, OU1
Dim Shared As String IN(6), OU(6)
Dim As Byte i, j, k
For i = 0 To 6 : Read IN(i) : Next i
Data "violet", "red", "green", "indigo", "blue", "yellow", "orange"
OU(0) = IN(0)

Sub PrintOrder
    Print : Print "{";
    If n = 1 Then Print OU(n-1);")" : Exit Sub
    For q As Byte = 0 To n-2
        Print OU(q);", ";
    Next q
    Print OU(n-1);"}"
End Sub

Sub InteractiveCompare
    Dim As String*1 T
    Print "Es "; IN1; " < "; OU1; "? (S/N) ";
    Do: T = Inkey$: Loop Until T <> ""
    If Instr("snSN", T) Then Print Ucase(T)
    r = T = "S"
End Sub

For i = 1 To 6
    IN1 = IN(i)
    For j = 0 To n-1
        OU1 = OU(j)
        InteractiveCompare
        If r < 0 Then
            For k = n To j+1 Step -1
                OU(k) = OU(k-1)
            Next k
            OU(j) = IN1
            n += 1
            Exit For, For
        End If
    Next j
    OU(n) = IN1
    n += 1
Next i
PrintOrder
Sleep


package main

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

var count int = 0

func interactiveCompare(s1, s2 string) bool {
    count++
    fmt.Printf("(%d) Is %s < %s? ", count, s1, s2)
    var response string
    _, err := fmt.Scanln(&response)
    return err == nil && strings.HasPrefix(response, "y")
}

func main() {
    items := []string{"violet", "red", "green", "indigo", "blue", "yellow", "orange"}

    var sortedItems []string

    // Use a binary insertion sort to order the items.  It should ask for
    // close to the minimum number of questions required
    for _, item := range items {
        fmt.Printf("Inserting '%s' into %s\n", item, sortedItems)
        // sort.Search performs the binary search using interactiveCompare to
        // rank the items
        spotToInsert := sort.Search(len(sortedItems), func(i int) bool {
            return interactiveCompare(item, sortedItems[i])
        })
        sortedItems = append(sortedItems[:spotToInsert],
                             append([]string{item}, sortedItems[spotToInsert:]...)...)
    }
    fmt.Println(sortedItems)
}


( ( palindrome
  =   a
    .     @(!arg:(%?a&utf$!a) ?arg !a)
        & palindrome$!arg
      | utf$!arg
  )
& ( desep
  =   x
    .     @(!arg:?x (" "|"-"|",") ?arg)
        & !x desep$!arg
      | !arg
  )
&     "In girum imus nocte et consumimur igni"
      "Я иду с мечем, судия"
      "The quick brown fox"
      "tregða, gón, reiði - er nóg að gert"
      "人人為我,我為人人"
      "가련하시다 사장집 아들딸들아 집장사 다시 하련가"
  : ?candidates
&   whl
  ' ( !candidates:%?candidate ?candidates
    &   out
      $ ( !candidate
          is
          (   palindrome$(low$(str$(desep$!candidate)))
            & indeed
          | not
          )
          a
          palindrome
        )
    )
&
);


import Control.Monad
import Control.Monad.ListM (sortByM, insertByM, partitionM, minimumByM)
import Data.Bool (bool)
import Data.Monoid
import Data.List

--------------------------------------------------------------------------------
isortM, msortM, tsortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]

-- merge sort from the Control.Monad.ListM library
msortM = sortByM

-- insertion sort
isortM cmp = foldM (flip (insertByM cmp)) []

-- tree sort aka qsort (which is not)
tsortM cmp = go
  where
    go [] = pure []
    go (h:t) = do (l, g) <- partitionM (fmap (LT /=) . cmp h) t
                  go l <+> pure [h] <+> go g
    (<+>) = liftM2 (++)


import java.util.*;

public class SortComp1 {
    public static void main(String[] args) {
        List<String> items = Arrays.asList("violet", "red", "green", "indigo", "blue", "yellow", "orange");
        List<String> sortedItems = new ArrayList<>();
        Comparator<String> interactiveCompare = new Comparator<String>() {
                int count = 0;
                Scanner s = new Scanner(System.in);
                public int compare(String s1, String s2) {
                    System.out.printf("(%d) Is %s <, =, or > %s. Answer -1, 0, or 1: ", ++count, s1, s2);
                    return s.nextInt();
                }
            };
        for (String item : items) {
            System.out.printf("Inserting '%s' into %s\n", item, sortedItems);
            int spotToInsert = Collections.binarySearch(sortedItems, item, interactiveCompare);
            // when item does not equal an element in sortedItems,
            // it returns bitwise complement of insertion point
            if (spotToInsert < 0) spotToInsert = ~spotToInsert;
            sortedItems.add(spotToInsert, item);
        }
        System.out.println(sortedItems);
    }
}


def inputOption($prompt; $options):
  def r:
    $prompt | stderr
    | input as $in
      | if $in|test($options) then $in else r end;
  r;

# Inserts item $x in the array input, which is kept sorted as per user input
# assuming it is already sorted.  $q is the prompt number.
# Input: [$q; $a]
# Output: [$qPrime, $aPrime]
def insortRight($x):
  . as [$q, $a]
  | { lo: 0, hi: ($a|length), $q }
  | until( .lo >= .hi;
        ( ((.lo + .hi)/2)|floor) as $mid
        | .q += 1
        | "\(.q): Is \($x) less than \($a[$mid])? y/n: " as $prompt
        | (inputOption($prompt; "[yn]") == "y") as $less
        | if ($less) then .hi = $mid
          else .lo = $mid + 1
          end)
   # insert at position .lo
   | [ .q, ($a[: .lo] + [x] + $a[.lo :]) ];

def order:
  reduce .[] as $item ( [0, []]; insortRight($item) )
  | .[1];

["violet red green indigo blue yellow orange"|splits(" ")]
| order as $ordered
| ("\nThe colors of the rainbow, in sorted order, are:",
    $ordered )


#include <string.h>

int palindrome(const char *s)
{
   int i,l;
   l = strlen(s);
   for(i=0; i<l/2; i++)
   {
     if ( s[i] != s[l-i-1] ) return 0;
   }
   return 1;
}


using System;

class Program
{
    static string Reverse(string value)
    {
        char[] chars = value.ToCharArray();
        Array.Reverse(chars);
        return new string(chars);
    }

    static bool IsPalindrome(string value)
    {
        return value == Reverse(value);
    }

    static void Main(string[] args)
    {
        Console.WriteLine(IsPalindrome("ingirumimusnocteetconsumimurigni"));
    }
}


const nrequests = [0]
const ordering = Dict("violet" => 7, "red" => 1, "green" => 4, "indigo" => 6, "blue" => 5,
                      "yellow" => 3, "orange" => 2)

function tellmeifgt(x, y)
    nrequests[1] += 1
    while true
        print("Is $x greater than $y?  (Y/N) =>  ")
        s = strip(readline())
        if length(s) > 0
            (s[1] == 'Y' || s[1] == 'y') && return true
            (s[1] == 'N' || s[1] == 'n') && return false
        end
    end
end

function orderbypair!(a::Vector)
    incr = div(length(a), 2)
    while incr > 0
        for i in incr+1:length(a)
            j = i
            tmp = a[i]
            while j > incr && tellmeifgt(a[j - incr], tmp)
                a[j] = a[j-incr]
                j -= incr
            end
            a[j] = tmp
        end
        if incr == 2
            incr = 1
        else
            incr = floor(Int, incr * 5.0 / 11)
        end
    end
    return a
end

const words = String.(split("violet red green indigo blue yellow orange", r"\s+"))
println("Unsorted: $words")
println("Sorted: $(orderbypair!(words)). Total requests: $(nrequests[1]).")


ClearAll[HumanOrderCheck]
HumanOrderCheck[opt1_,opt2_]:=ChoiceDialog[[email protected]{"Is {",opt1,", ", opt2, "} ordered?"},{"Yes"->True,"No"->False}]
Sort[{"violet","red","green","indigo","blue","yellow","orange"},HumanOrderCheck]


import algorithm, strformat, strutils

let list = ["violet", "red", "green", "indigo", "blue", "yellow", "orange"]

var count = 0

proc comp(x, y: string): int =
  if x == y: return 0
  inc count
  while true:
    stdout.write &"{count:>2}) Is {x} less than {y} (y/n)? "
    let answer = stdin.readLine()[0]
    case answer
    of 'y': return -1
    of 'n': return 1
    else: echo "Incorrect answer."

var sortedList: seq[string]

for elem in list:
  sortedList.insert(elem, sortedList.upperBound(elem, comp))

echo "Sorted list: ", sortedList.join(", ")


let () =
  let count = ref 0 in
  let mycmp s1 s2 = (
    incr count;
    Printf.printf "(%d) Is %s <, ==, or > %s? Answer -1, 0, or 1: " (!count) s1 s2;
    read_int ()
  ) in
  let items = ["violet"; "red"; "green"; "indigo"; "blue"; "yellow"; "orange"] in
  let sorted = List.sort mycmp items in
  List.iter (Printf.printf "%s ") sorted;
  print_newline ()


#!/usr/bin/perl

use strict; # https://rosettacode.org/wiki/Order_by_pair_comparisons
use warnings;

sub ask
  {
  while( 1 )
    {
    print "Compare $a to $b [<,=,>]: ";
    <STDIN> =~ /[<=>]/ and return +{qw( < -1 = 0 > 1 )}->{$&};
    }
  }

my @sorted = sort ask qw( violet red green indigo blue yellow orange );
print "sorted: @sorted\n";


#include <string>
#include <algorithm>

bool is_palindrome(std::string const& s)
{
  return std::equal(s.begin(), s.end(), s.rbegin());
}


(defn palindrome? [s]
  (= s (clojure.string/reverse s)))


integer qn = 0
function ask(string a, b)
    qn += 1
    printf(1,"%d: Is %s < %s (Y/N)?:",{qn,a,b})
    integer ch = upper(wait_key())
    printf(1,"%s\n",ch)
    return iff(ch='Y'?-1:1)
end function

?custom_sort(ask,split("violet orange red yellow green blue indigo"))


def _insort_right(a, x, q):
    """
    Insert item x in list a, and keep it sorted assuming a is sorted.
    If x is already in a, insert it to the right of the rightmost x.
    """

    lo, hi = 0, len(a)
    while lo < hi:
        mid = (lo+hi)//2
        q += 1
        less = input(f"{q:2}: IS {x:>6} LESS-THAN {a[mid]:>6} ? y/n: ").strip().lower() == 'y'
        if less: hi = mid
        else: lo = mid+1
    a.insert(lo, x)
    return q

def order(items):
    ordered, q = [], 0
    for item in items:
        q = _insort_right(ordered, item, q)
    return ordered, q

if __name__ == '__main__':
    items = 'violet red green indigo blue yellow orange'.split()
    ans, questions = order(items)
    print('\n' + ' '.join(ans))


 [ $ "Is " swap join
   $ " before " join
   swap join
   $ "? (y/n) " join
   input $ "y" = ]       is askuser

$ "red orange yellow green blue indigo violet"
say "Correct order --> "
dup echo$ cr cr
nest$ shuffle
dup witheach [ echo$ sp ] cr cr
sortwith askuser cr
witheach [ echo$ sp ] cr


my $ask_count = 0;
sub by_asking ( $a, $b ) {
    $ask_count++;
    constant $fmt = '%2d. Is %-6s [ less than | greater than | equal to ] %-6s? ( < = > ) ';
    constant %o = '<' => Order::Less,
                  '=' => Order::Same,
                  '>' => Order::More;

    loop {
        my $input = prompt sprintf $fmt, $ask_count, $a, $b;
        return $_ with %o{ $input.trim };
        say "Invalid input '$input'";
    }
}

my @colors = <violet red green indigo blue yellow orange>;
my @sorted = @colors.sort: &by_asking;
say (:@sorted);

die if @sorted».substr(0,1).join ne 'roygbiv';
my $expected_ask_count = @colors.elems * log(@colors.elems);
warn "Too many questions? ({:$ask_count} > {:$expected_ask_count})" if $ask_count > $expected_ask_count;


% Reverse a string
str_reverse = proc (s: string) returns (string)
    chs: array[char] := array[char]$predict(0, string$size(s))
    for c: char in string$chars(s) do
        array[char]$addl(chs, c)
    end
    return (string$ac2s(chs))
end str_reverse

% 'Normalize' a string (remove everything but letters and make uppercase)
normalize = proc (s: string) returns (string)
    chs: array[char] := array[char]$predict(0, string$size(s))
    for c: char in string$chars(s) do
        if c>='a' cand c<='z' then
            c := char$i2c(char$c2i(c) - 32)
        end
        if c>='A' cand c<='Z' then
            array[char]$addh(chs, c)
        end
    end
    return (string$ac2s(chs))
end normalize

% Check if a string is an exact palindrome
palindrome = proc (s: string) returns (bool)
    return (s = str_reverse(s))
end palindrome

% Check if a string is an inexact palindrome
inexact_palindrome = proc (s: string) returns (bool)
    return (palindrome(normalize(s)))
end inexact_palindrome

% Test cases
start_up = proc ()
    po: stream := stream$primary_output()
    tests: array[string] := array[string]$[
        "rotor", "racecar", "RACEcar", "level", "rosetta",
        "A man, a plan, a canal: Panama",
        "Egad, a base tone denotes a bad age",
        "This is not a palindrome"
    ]

    for test: string in array[string]$elements(tests) do
        stream$puts(po, "\"" || test || "\": ")
        if palindrome(test) then
            stream$putl(po, "exact palindrome")
        elseif inexact_palindrome(test) then
            stream$putl(po, "inexact palindrome")
        else
            stream$putl(po, "not a palindrome")
        end
    end
end start_up


       identification division.
       function-id. palindromic-test.

       data division.
       linkage section.
       01 test-text            pic x any length.
       01 result               pic x.
          88 palindromic       value high-value
                               when set to false low-value.

       procedure division using test-text returning result.

       set palindromic to false
       if test-text equal function reverse(test-text) then
           set palindromic to true
       end-if

       goback.
       end function palindromic-test.


/*REXX pgm orders some items based on (correct) answers from a  carbon─based life form. */
colors= 'violet red green indigo blue yellow orange'
                                        q= 0;    #= 0;    $=
           do j=1  for words(colors);   q= inSort( word(colors, j), q)
           end   /*j*/                           /*poise questions the CBLF about order.*/
say
           do i=1  for #;   say '   query'   right(i, length(#) )":"   !.i
           end   /*i*/                           /* [↑] show the list of queries to CBLF*/
say
say 'final ordering: '    $
exit 0
/*──────────────────────────────────────────────────────────────────────────────────────*/
getAns: #= # + 1;    _= copies('─', 8);     y_n= '     Answer  y/n'
              do try=0  until ansU='Y'  |  ansU='N'
              if try>0  then say _ '(***error***)  incorrect answer.'
              ask= _  ' is '   center(x,6)   " less than "   center(word($, mid+1),6)  '?'
              say ask   y_n;  parse pull ans 1 ansU;   ansU= space(ans);   upper ansU
              end   /*until*/;      !.#= ask   '  '    ans;                return
/*──────────────────────────────────────────────────────────────────────────────────────*/
inSort: parse arg x, q;          hi= words($);          lo= 0
              do q=q-1  while lo<hi;              mid= (lo+hi) % 2
              call getAns;  if ansU=='Y'  then hi= mid
                                          else lo= mid + 1
              end   /*q*/
        $= subword($, 1, lo)  x  subword($, lo+1);      return q


items = ["violet", "red", "green", "indigo", "blue", "yellow", "orange"]
count = 0
sortedItems = []
items.each {|item|
  puts "Inserting '#{item}' into #{sortedItems}"
  spotToInsert = sortedItems.bsearch_index{|x|
    count += 1
    print "(#{count}) Is #{item} < #{x}? "
    gets.start_with?('y')
  } || sortedItems.length # if insertion point is at the end, bsearch_index returns nil
  sortedItems.insert(spotToInsert, item)
}
p sortedItems


import "/ioutil" for Input
import "/fmt" for Fmt

// Inserts item x in list a, and keeps it sorted assuming a is already sorted.
// If x is already in a, inserts it to the right of the rightmost x.
var insortRight = Fn.new{ |a, x, q|
    var lo = 0
    var hi = a.count
    while (lo < hi) {
        var mid = ((lo + hi)/2).floor
        q = q + 1
        var prompt = Fmt.swrite("$2d: Is $6s less than $6s ? y/n: ", q, x, a[mid])
        var less = Input.option(prompt, "yn") == "y"
        if (less) {
            hi = mid
        } else {
            lo = mid + 1
        }
     }
     a.insert(lo, x)
     return q
}

var order = Fn.new { |items|
    var ordered = []
    var q = 0
    for (item in items) {
        q = insortRight.call(ordered, item, q)
    }
    return ordered
}

var items = "violet red green indigo blue yellow orange".split(" ")
var ordered = order.call(items)
System.print("\nThe colors of the rainbow, in sorted order, are:")
System.print(ordered)


    String::isPalindrome = ->
        for i in [0...@length / 2] when @[i] isnt @[@length - (i + 1)]
            return no
        yes

    String::stripped = -> @toLowerCase().replace /\W/gi, ''

    console.log "'#{ str }' : #{ str.stripped().isPalindrome() }" for str in [
        'In girum imus nocte et consumimur igni'
        'A man, a plan, a canal: Panama!'
        'There is no spoon.'
    ]


(defun palindrome-p (s)
  (string= s (reverse s)))


MODULE BbtPalindrome;
IMPORT StdLog;

PROCEDURE ReverseStr(str: ARRAY OF CHAR): POINTER TO ARRAY OF CHAR;
VAR
	top,middle,i: INTEGER;
	c: CHAR;
	rStr: POINTER TO ARRAY OF CHAR;
BEGIN
	NEW(rStr,LEN(str$) + 1);
	top := LEN(str$) - 1; middle := (top - 1) DIV 2;
	FOR i := 0 TO middle DO
		rStr[i] := str[top - i];
		rStr[top - i] := str[i];
	END;
	IF ODD(LEN(str$)) THEN rStr[middle + 1] := str[middle + 1] END;
	RETURN rStr;
END ReverseStr;

PROCEDURE IsPalindrome(str: ARRAY OF CHAR): BOOLEAN;
BEGIN
	RETURN str = ReverseStr(str)$;
END IsPalindrome;

PROCEDURE Do*;
VAR
	x: CHAR;
BEGIN
	StdLog.String("'salalas' is palindrome?:> ");
	StdLog.Bool(IsPalindrome("salalas"));StdLog.Ln;
	StdLog.String("'madamimadam' is palindrome?:> ");
	StdLog.Bool(IsPalindrome("madamimadam"));StdLog.Ln;
	StdLog.String("'abcbda' is palindrome?:> ");
	StdLog.Bool(IsPalindrome("abcbda"));StdLog.Ln;
END Do;
END BbtPalindrome.


include "cowgol.coh";

# Check if a string is a palindrome
sub palindrome(word: [uint8]): (r: uint8) is
    r := 1;

    # empty string is a palindrome
    if [word] == 0 then
        return;
    end if;

    # find the end of the word
    var end_ := word;
    while [@next end_] != 0 loop
        end_ := @next end_;
    end loop;

    # check if bytes match in both directions
    while word < end_ loop
        if [word] != [end_] then
            r := 0;
            return;
        end if;
        word := @next word;
        end_ := @prev end_;
    end loop;
end sub;

# Check if a string is an inexact palindrome
sub inexact(word: [uint8]): (r: uint8) is
    var buf: uint8[256];
    var ptr := &buf[0];
    # filter non-letters and non-numbers
    while [word] != 0 loop
        var c := [word];
        if (c >= 'a' and c <= 'z') or (c >= '0' and c <= '9') then
            # copy lowercase letters and numbers over verbatim
            [ptr] := c;
            ptr := @next ptr;
        elseif c >= 'A' and c <= 'Z' then
            # make uppercase letters lowercase
            [ptr] := c | 32;
            ptr := @next ptr;
        end if;
        word := @next word;
    end loop;
    [ptr] := 0;
    r := palindrome(&buf[0]);
end sub;

var tests: [uint8][] := {
    "civic", "level", "racecar",
    "A man, a plan, a canal: Panama",
    "Egad, a base tone denotes a bad age",
    "There is no spoon."
};

var i: @indexof tests := 0;
while i < @sizeof tests loop
    print(tests[i]);
    print(": ");
    if palindrome(tests[i]) == 1 then
        print("exact palindrome\n");
    elseif inexact(tests[i]) == 1 then
        print("inexact palindrome\n");
    else
        print("not a palindrome\n");
    end if;
    i := i + 1;
end loop;


import std.traits, std.algorithm;

bool isPalindrome1(C)(in C[] s) pure /*nothrow*/
if (isSomeChar!C) {
    auto s2 = s.dup;
    s2.reverse(); // works on Unicode too, not nothrow.
    return s == s2;
}

void main() {
    alias pali = isPalindrome1;
    assert(pali(""));
    assert(pali("z"));
    assert(pali("aha"));
    assert(pali("sees"));
    assert(!pali("oofoe"));
    assert(pali("deified"));
    assert(!pali("Deified"));
    assert(pali("amanaplanacanalpanama"));
    assert(pali("ingirumimusnocteetconsumimurigni"));
    assert(pali("salÃ las"));
}


bool isPalindrome(String s){
  for(int i = 0; i < s.length/2;i++){
    if(s[i] != s[(s.length-1) -i])
      return false;
  }
  return true;
}


uses
  SysUtils, StrUtils;

function IsPalindrome(const aSrcString: string): Boolean;
begin
  Result := SameText(aSrcString, ReverseString(aSrcString));
end;


func isPalindrom(str) {
    str == str.Reverse()
}

print(isPalindrom("ingirumimusnocteetconsumimurigni"))


palindrome?:
	local :seq chars
	local :len-seq -- len seq

	for i range 0 / len-seq 2:
		if /= seq! i seq! - len-seq i:
			return false
	true

!. palindrome? "ingirumimusnocteetconsumimurigni"
!. palindrome? "nope"


def isPalindrome(string :String) {
  def upper := string.toUpperCase()
  def last := upper.size() - 1
  for i => c ? (upper[last - i] != c) in upper(0, upper.size() // 2) {
    return false
  }
  return true
}


;; returns #t or #f
(define (palindrome? string)
(equal? (string->list string) (reverse (string->list string))))

;; to strip spaces, use the following
;;(define (palindrome? string)
;;(let ((string (string-replace string "/\ /" "" "g")))
;;(equal? (string->list string) (reverse (string->list string)))))


	is_palindrome (a_string: STRING): BOOLEAN
			-- Is `a_string' a palindrome?
		require
			string_attached: a_string /= Void
		local
			l_index, l_count: INTEGER
		do
			from
				Result := True
				l_index := 1
				l_count := a_string.count
			until
				l_index >= l_count - l_index + 1 or not Result
			loop
				Result := (Result and a_string [l_index] = a_string [l_count - l_index + 1])
				l_index := l_index + 1
			end
		end


open list string

isPalindrome xs = xs == reverse xs
isPalindrome <| toList "ingirumimusnocteetconsumimurigni"


defmodule PalindromeDetection do
  def is_palindrome(str), do: str == String.reverse(str)
end


import String exposing (reverse, length)
import Html exposing (Html, Attribute, text, div, input)
import Html.Attributes exposing (placeholder, value, style)
import Html.Events exposing (on, targetValue)
import Html.App exposing (beginnerProgram)

-- The following function (copied from Haskell) satisfies the
-- rosettacode task description.
is_palindrome x = x == reverse x

-- The remainder of the code demonstrates the use of the function
-- in a complete Elm program.
main = beginnerProgram { model = "" , view = view , update = update }

update newStr oldStr = newStr

view : String -> Html String
view candidate =
  div []
    ([ input
        [ placeholder "Enter a string to check."
        , value candidate
        , on "input" targetValue
        , myStyle
        ]
        []
     ] ++
     [ let testResult =
             is_palindrome candidate

           statement =
             if testResult then "PALINDROME!" else "not a palindrome"

       in div [ myStyle] [text statement]
     ])

myStyle : Attribute msg
myStyle =
  style
    [ ("width", "100%")
    , ("height", "20px")
    , ("padding", "5px 0 0 5px")
    , ("font-size", "1em")
    , ("text-align", "left")
    ]


(defun palindrome (s)
  (string= s (reverse s)))


-module( palindrome ).

-export( [is_palindrome/1, task/0] ).

is_palindrome( String ) -> String =:= lists:reverse(String).

task() ->
	display( "abcba" ),
	display( "abcdef" ),
	Latin = "In girum imus nocte et consumimur igni",
	No_spaces_same_case = lists:append( string:tokens(string:to_lower(Latin), " ") ),
	display( Latin, No_spaces_same_case ).

display( String ) -> io:fwrite( "Is ~p a palindrom? ~p~n", [String, is_palindrome(String)] ).

display( String1, String2 ) -> io:fwrite( "Is ~p a palindrom? ~p~n", [String1, is_palindrome(String2)] ).


F partitions(lengths)
   [[[Int]]] r
   [(Int, Int)] slices
   V delta = -1
   V idx = 0
   L(length) lengths
      assert(length >= 0, ‘lengths must not be negative.’)
      delta += length
      slices.append((idx, delta))
      idx += length

   V n = sum(lengths)
   V perm = Array(1 .. n)

   L
      [[Int]] part
      L(start, end) slices
         V s = perm[start .. end]
         I !s.is_sorted()
            L.break
         part.append(s)
      L.was_no_break
         r.append(part)

      I !perm.next_permutation()
         L.break

   R r

F toString(part)
   V result = ‘(’
   L(s) part
      I result.len > 1
         result ‘’= ‘, ’
      result ‘’= ‘{’s.join(‘, ’)‘}’
   R result‘)’

F displayPermutations(lengths)
   print(‘Ordered permutations for (’lengths.join(‘, ’)‘):’)
   L(part) partitions(lengths)
      print(toString(part))

:start:
I :argv.len > 1
   displayPermutations(:argv[1..].map(Int))
E
   displayPermutations([2, 0, 2])


function isPalindrome(sequence s)
    for i = 1 to length(s)/2 do
        if s[i] != s[$-i+1] then
            return 0
        end if
    end for
    return 1
end function


ISPALINDROME
=LAMBDA(s,
    LET(
        lcs, FILTERP(
            LAMBDA(c, " " <> c)
        )(
            CHARS(LOWER(s))
        ),
        CONCAT(lcs) = CONCAT(REVERSE(lcs))
    )
)


with Ada.Containers.Indefinite_Ordered_Sets;
with Ada.Containers.Ordered_Sets;
package Partitions is
   -- Argument type for Create_Partitions: Array of Numbers
   type Arguments is array (Positive range <>) of Natural;
   package Number_Sets is new Ada.Containers.Ordered_Sets
     (Natural);
   type Partition is array (Positive range <>) of Number_Sets.Set;
   function "<" (Left, Right : Partition) return Boolean;
   package Partition_Sets is new Ada.Containers.Indefinite_Ordered_Sets
     (Partition);
   function Create_Partitions (Args : Arguments) return Partition_Sets.Set;
end Partitions;


      DIM list1%(2) : list1%() = 2, 0, 2
      PRINT "partitions(2,0,2):"
      PRINT FNpartitions(list1%())
      DIM list2%(2) : list2%() = 1, 1, 1
      PRINT "partitions(1,1,1):"
      PRINT FNpartitions(list2%())
      DIM list3%(3) : list3%() = 1, 2, 0, 1
      PRINT "partitions(1,2,0,1):"
      PRINT FNpartitions(list3%())
      END

      DEF FNpartitions(list%())
      LOCAL i%, j%, n%, p%, o$, x%()
      n% = DIM(list%(),1)
      DIM x%(SUM(list%())-1)
      FOR i% = 0 TO n%
        IF list%(i%) THEN
          FOR j% = 1 TO list%(i%)
            x%(p%) = i%
            p% += 1
          NEXT
        ENDIF
      NEXT i%
      REPEAT
        FOR i% = 0 TO n%
          o$ += " ( "
          FOR j% = 0 TO DIM(x%(),1)
            IF x%(j%) = i% o$ += STR$(j%+1) + " "
          NEXT
          o$ += ")"
        NEXT i%
        o$ += CHR$13 + CHR$10
      UNTIL NOT FNperm(x%())
      = o$

      DEF FNperm(x%())
      LOCAL i%, j%
      FOR i% = DIM(x%(),1)-1 TO 0 STEP -1
        IF x%(i%) < x%(i%+1) EXIT FOR
      NEXT
      IF i% < 0 THEN = FALSE
      j% = DIM(x%(),1)
      WHILE x%(j%) <= x%(i%) j% -= 1 : ENDWHILE
      SWAP x%(i%), x%(j%)
      i% += 1
      j% = DIM(x%(),1)
      WHILE i% < j%
        SWAP x%(i%), x%(j%)
        i% += 1
        j% -= 1
      ENDWHILE
      = TRUE


#include <stdio.h>

int next_perm(int size, int * nums)
{
        int *l, *k, tmp;

        for (k = nums + size - 2; k >= nums && k[0] >= k[1]; k--) {};
        if (k < nums) return 0;

        for (l = nums + size - 1; *l <= *k; l--) {};
        tmp = *k; *k = *l; *l = tmp;

        for (l = nums + size - 1, k++; k < l; k++, l--) {
                tmp = *k; *k = *l; *l = tmp;
        }

        return 1;
}

void make_part(int n, int * sizes)
{
        int x[1024], i, j, *ptr, len = 0;

        for (ptr = x, i = 0; i < n; i++)
                for (j = 0, len += sizes[i]; j < sizes[i]; j++, *(ptr++) = i);

        do {
                for (i = 0; i < n; i++) {
                        printf(" { ");
                        for (j = 0; j < len; j++)
                                if (x[j] == i) printf("%d ", j);

                        printf("}");
                }
                printf("\n");
        } while (next_perm(len, x));
}

int main()
{
        int s1[] = {2, 0, 2};
        int s2[] = {1, 2, 3, 4};

        printf("Part 2 0 2:\n");
        make_part(3, s1);

        printf("\nPart 1 2 3 4:\n");
        make_part(4, s2);

        return 1;
}


let isPalindrome (s: string) =
   let arr = s.ToCharArray()
   arr = Array.rev arr


USING: kernel sequences ;
: palindrome? ( str -- ? ) dup reverse = ;


/* created by Aykayayciti Earl Lamont Montgomery
April 9th, 2018 */

function is_palindrome(a)
	a = strUpper(a).replace(" ", "")
	b = a[-1:0]
	return b == a
end

a = "mom"
> is_palindrome(a)


using System;
using System.Linq;
using System.Collections.Generic;

public static class OrderedPartitions
{
    public static void Main() {
        var input = new [] { new[] { 0, 0, 0, 0, 0 }, new[] { 2, 0, 2 }, new[] { 1, 1, 1 } };
        foreach (int[] sizes in input) {
            foreach (var partition in Partitions(sizes)) {
                Console.WriteLine(partition.Select(set => set.Delimit(", ").Encase('{','}')).Delimit(", ").Encase('(', ')'));
            }
            Console.WriteLine();
        }
    }

    static IEnumerable<IEnumerable<int[]>> Partitions(params int[] sizes) {
        var enumerators = new IEnumerator<int[]>[sizes.Length];
        var unused = Enumerable.Range(1, sizes.Sum()).ToSortedSet();
        var arrays = sizes.Select(size => new int[size]).ToArray();

        for (int s = 0; s >= 0; ) {
            if (s == sizes.Length) {
                yield return arrays;
                s--;
            }
            if (enumerators[s] == null) {
                enumerators[s] = Combinations(sizes[s], unused.ToArray()).GetEnumerator();
            } else {
                unused.UnionWith(arrays[s]);
            }
            if (enumerators[s].MoveNext()) {
                enumerators[s].Current.CopyTo(arrays[s], 0);
                unused.ExceptWith(arrays[s]);
                s++;
            } else {
                enumerators[s] = null;
                s--;
            }
        }
    }

    static IEnumerable<T[]> Combinations<T>(int count, params T[] array) {
        T[] result = new T[count];
        foreach (int pattern in BitPatterns(array.Length - count, array.Length)) {
            for (int b = 1 << (array.Length - 1), i = 0, r = 0; b > 0; b >>= 1, i++) {
                if ((pattern & b) == 0) result[r++] = array[i];
            }
            yield return result;
        }
    }

    static IEnumerable<int> BitPatterns(int ones, int length) {
        int initial = (1 << ones) - 1;
        int blockMask = (1 << length) - 1;
        for (int v = initial; v >= initial; ) {
            yield return v;
            if (v == 0) break;

            int w = (v | (v - 1)) + 1;
            w |= (((w & -w) / (v & -v)) >> 1) - 1;
            v = w & blockMask;
        }
    }

    static string Delimit<T>(this IEnumerable<T> source, string separator) => string.Join(separator, source);
    static string Encase(this string s, char start, char end) => start + s + end;
}


class Palindrome
{
  // Function to test if given string is a palindrome
  public static Bool isPalindrome (Str str)
  {
    str == str.reverse
  }

  // Give it a test run
  public static Void main ()
  {
    echo (isPalindrome(""))
    echo (isPalindrome("a"))
    echo (isPalindrome("aa"))
    echo (isPalindrome("aba"))
    echo (isPalindrome("abb"))
    echo (isPalindrome("salàlas"))
    echo (isPalindrome("In girum imus nocte et consumimur igni".lower.replace(" ","")))
  }
}


#APPTYPE CONSOLE

FUNCTION stripNonAlpha(BYVAL s AS STRING) AS STRING
	DIM sTemp AS STRING = ""
	DIM c AS STRING
	FOR DIM i = 1 TO LEN(s)
		c = MID(s, i, 1)
		IF INSTR("ABCDEFGHIJKLMNOPQRSTUVWXYZ", c, 0, 1) THEN
			sTemp = stemp & c
		END IF
	NEXT
	RETURN sTemp
END FUNCTION

FUNCTION IsPalindrome(BYVAL s AS STRING) AS INTEGER
	FOR DIM i = 1 TO STRLEN(s) \ 2 ' only check half of the string, as scanning from both ends
		IF s{i} <> s{STRLEN - (i - 1)} THEN RETURN FALSE 'comparison is not case sensitive
	NEXT

	RETURN TRUE
END FUNCTION

PRINT IsPalindrome(stripNonAlpha("A Toyota"))
PRINT IsPalindrome(stripNonAlpha("Madam, I'm Adam"))
PRINT IsPalindrome(stripNonAlpha("the rain in Spain falls mainly on the rooftops"))

PAUSE


#include <iostream>
#include <algorithm>
#include <vector>
#include <numeric>

void partitions(std::vector<size_t> args) {
  size_t sum = std::accumulate(std::begin(args), std::end(args), 0);
  std::vector<size_t> nums(sum);
  std::iota(std::begin(nums), std::end(nums), 1);
  do {
    size_t total_index = 0;
    std::vector<std::vector<size_t>> parts;
    for (const auto& a : args) {
      std::vector<size_t> part;
      bool cont = true;
      for (size_t j = 0; j < a; ++j) {
        for (const auto& p : part) {
          if (nums[total_index] < p) {
            cont = false;
            break;
          }
        }
        if (cont) {
          part.push_back(nums[total_index]);
          ++total_index;
        }
      }
      if (part.size() != a) {
        break;
      }
      parts.push_back(part);
    }
    if (parts.size() == args.size()) {
      std::cout << "(";
      for (const auto& p : parts) {
        std::cout << "{ ";
        for (const auto& e : p) {
          std::cout << e << " ";
        }
        std::cout << "},";
      }
      std::cout << ")," << std::endl;
    }
  } while (std::next_permutation(std::begin(nums), std::end(nums)));
}

int main() {
  std::vector<size_t> args = { 2, 0, 2 };
  partitions(args);
  std::cin.ignore();
  std::cin.get();
  return 0;
}


: first   over [email protected] ;
: last    >r 2dup + 1- [email protected] r> swap ;
: palindrome? ( c-addr u -- f )
  begin
    dup 1 <=      if 2drop true  exit then
    first last <> if 2drop false exit then
    1 /string 1-
  again ;


program palindro

  implicit none

  character(len=*), parameter :: p = "ingirumimusnocteetconsumimurigni"

  print *, is_palindro_r(p)
  print *, is_palindro_r("anothertest")
  print *, is_palindro2(p)
  print *, is_palindro2("test")
  print *, is_palindro(p)
  print *, is_palindro("last test")

contains


(defun fill-part (x i j l)
  (let ((e (elt x i)))
    (loop for c in l do
	    (loop while (>= j (length e)) do
		  (setf j 0 e (elt x (incf i))))
	    (setf (elt e j) c)
	    (incf j))))

;;; take a list of lists and return next partitioning
;;; it's caller's responsibility to ensure each sublist is sorted
(defun next-part (list cmp)
  (let* ((l (coerce list 'vector))
	 (i (1- (length l)))
	 (e (elt l i)))
    (loop while (<= 0 (decf i)) do
	  ;; e holds all the right most elements
	  (let ((p (elt l i)) (q (car (last e))))
	    ;; find the right-most list that has an element that's smaller
	    ;; than _something_ in later lists
	    (when (and p (funcall cmp (first p) q))
	      ;; find largest element that can be increased
	      (loop for j from (1- (length p)) downto 0 do
		    (when (funcall cmp (elt p j) q)
		      ;; find the smallest element that's larger than
		      ;; that largest
		      (loop for x from 0 to (1- (length e)) do
			    (when (funcall cmp (elt p j) (elt e x))
			      (rotatef (elt p j) (elt e x))
			      (loop while (< (incf j) (length p)) do
			      	(setf (elt p j) (elt e (incf x))
				      (elt e x) nil))
			      (fill-part l i j (remove nil e))
			      (return-from next-part l))))
		    (setf e (append e (list (elt p j))))))
	    (setf e (append e p))))))

(let ((a '#((1 2) () (3 4))))
  (loop while a do
	(format t "~a~%" a)
	(setf a (next-part a #'<))))

(write-line "with dupe elements:")
(let ((a '#((a c) (c c d))))
  (loop while a do
	(format t "~a~%" a)
	(setf a (next-part a #'string<))))


' version 20-06-2015
' compile with: fbc -s console "filename".bas

#Ifndef TRUE        ' define true and false for older freebasic versions
    #Define FALSE 0
    #Define TRUE Not FALSE
#EndIf

Function reverse(norm As String) As Integer

    Dim As String rev
    Dim As Integer i, l = Len(norm) -1

    rev = norm
    For i = 0 To l
        rev[l-i] = norm[i]
    Next

    If norm = rev Then
        Return TRUE
    Else
        Return FALSE
    End If

End Function

Function cleanup(in As String, action As String = "") As String
    ' action = "" do nothing, [l|L] = convert to lowercase,
    ' [s|S] = strip spaces,  [p|P] = strip punctuation.
    If action = "" Then Return in

    Dim As Integer i, p_, s_
    Dim As String ch

    action = LCase(action)
    For i = 1 To Len(action)
        ch = Mid(action, i, 1)
        If ch = "l" Then in = LCase(in)
        If ch = "p" Then
            p_ = 1
        ElseIf ch = "s" Then
            s_ = 1
        End If
    Next

    If p_ = 0 And s_ = 0 Then Return in

    Dim As String unwanted, clean

    If s_ = 1 Then unwanted = " "
    If p_ = 1 Then unwanted = unwanted + "`[email protected]#$%^&*()-=_+[]{}\|;:',.<>/?"

    For i = 1 To Len(in)
        ch = Mid(in, i, 1)
        If InStr(unwanted, ch) = 0 Then clean = clean + ch
    Next

    Return clean

End Function

' ------=< MAIN >=------

Dim As String test = "In girum imus nocte et consumimur igni"
'IIf ( cond, true, false ), true and false must be of the same type (num, string, UDT)
Print
Print "                 reverse(test) = "; IIf(reverse(test) = FALSE, "FALSE", "TRUE")
Print "  reverse(cleanup(test,""l"")) = "; IIf(reverse(cleanup(test,"l")) = FALSE, "FALSE", "TRUE")
Print " reverse(cleanup(test,""ls"")) = "; IIf(reverse(cleanup(test,"ls")) = FALSE, "FALSE", "TRUE")
Print "reverse(cleanup(test,""PLS"")) = "; IIf(reverse(cleanup(test,"PLS")) = FALSE, "FALSE", "TRUE")

' empty keyboard buffer
While InKey <> "" : Wend
Print : Print : Print "Hit any key to end program"
Sleep
End


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

alias iRNG = int[];

iRNG[][] orderPart(iRNG blockSize...) {
    iRNG tot = iota(1, 1 + blockSize.sum).array;

    iRNG[][] p(iRNG s, in iRNG b) {
        if (b.empty)
            return [[]];
        iRNG[][] res;
        foreach (c; s.combinations(b[0]))
            foreach (r; p(setDifference(s, c).array, b.dropOne))
                res ~= c.dup ~ r;
        return res;
    }

    return p(tot, blockSize);
}

void main(in string[] args) {
    auto b = args.length > 1 ? args.dropOne.to!(int[]) : [2, 0, 2];
    writefln("%(%s\n%)", b.orderPart);
}


(lib 'list) ;; (combinations L k)

;; add a combination to each partition in ps
(define (pproduct c ps) (for/list ((x ps)) (cons c x)))

;; apply to any type of set S
;; ns is list of cardinals for each partition
;;     for all combinations Ci of n objects from  S
;;           set S <- LS minus Ci , set n <- next n , and recurse

(define (_partitions S ns )
    (cond
    ([empty? (rest ns)]  (list (combinations S (first ns))))
    (else
        (for/fold (parts null)
        ([c (combinations S (first ns))])
        (append
           parts
           (pproduct c (_partitions (set-substract S c) (rest ns))))))))

;; task : S = ( 0 , 1 ... n-1) args = ns
(define (partitions . args)
    (for-each
	 writeln
        (_partitions (range 1  (1+ (apply + args))) args )))


ZapGremlins := function(s)
  local upper, lower, c, i, n, t;
  upper := "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
  lower := "abcdefghijklmnopqrstuvwxyz";
  t := [ ];
  i := 1;
  for c in s do
    n := Position(upper, c);
    if n <> fail then
      t[i] := lower[n];
      i := i + 1;
    else
      n := Position(lower, c);
      if n <> fail then
        t[i] := c;
        i := i + 1;
      fi;
    fi;
  od;
  return t;
end;

IsPalindrome := function(s)
  local t;
  t := ZapGremlins(s);
  return t = Reversed(t);
end;


defmodule Ordered do
  def partition([]), do: [[]]
  def partition(mask) do
    sum = Enum.sum(mask)
    if sum == 0 do
      [Enum.map(mask, fn _ -> [] end)]
    else
      Enum.to_list(1..sum)
      |> permute
      |> Enum.reduce([], fn perm,acc ->
           {_, part} = Enum.reduce(mask, {perm,[]}, fn num,{pm,a} ->
             {p, rest} = Enum.split(pm, num)
             {rest, [Enum.sort(p) | a]}
           end)
           [Enum.reverse(part) | acc]
         end)
      |> Enum.uniq
    end
  end

  defp permute([]), do: [[]]
  defp permute(list), do: for x <- list, y <- permute(list -- [x]), do: [x|y]
end

Enum.each([[],[0,0,0],[1,1,1],[2,0,2]], fn test_case ->
  IO.puts "\npartitions #{inspect test_case}:"
  Enum.each(Ordered.partition(test_case), fn part ->
    IO.inspect part
  end)
end)


Function Perm(x() As Integer) As Boolean
    Dim As Integer i, j
    For i = Ubound(x,1)-1 To 0 Step -1
        If x(i) < x(i+1) Then Exit For
    Next i
    If i < 0 Then Return False
    j = Ubound(x,1)
    While x(j) <= x(i)
        j -= 1
    Wend
    Swap x(i), x(j)
    i += 1
    j = Ubound(x,1)
    While i < j
        Swap x(i), x(j)
        i += 1
        j -= 1
    Wend
    Return True
End Function

Function Particiones(list() As Integer) As String
    Dim As Integer i, j, n, p ', x()
    Dim As String oSS = ""
    n = Ubound(list)
    Dim As Integer x(n)
    For i = 0 To n
        If list(i) Then
            For j = 1 To list(i)
                x(p) = i
                p += 1
            Next j
        End If
    Next i
    Do
        For i = 0 To n
            oSS += " ( "
            For j = 0 To Ubound(x,1)
                If x(j) = i Then oSS += Str(j+1) + " "
            Next j
            oSS += ")"
        Next i
        oSS += Chr(13) + Chr(10)
    Loop Until Not Perm(x())
    Return oSS
End Function

Dim list2(2) As Integer = {1, 1, 1}
Print "Particiones(1, 1, 1):"
Print Particiones(list2())
Dim list3(3) As Integer = {1, 2, 0, 1}
Print !"\nParticiones(1, 2, 0, 1):"
Print Particiones(list3())

Sleep


//Setting a var from an argument passed to the script
var str;
str = argument0
//Takes out all spaces/anything that is not a letter or a number and turns uppercase letters to lowercase
str = string_lettersdigits(string_lower(string_replace(str,' ','')));
var inv;
inv = '';
//for loop that reverses the sequence
var i;
for (i = 0; i < string_length(str); i += 1;)
    {
    inv += string_copy(str,string_length(str)-i,1);
    }
//returns true if the sequence is a palindrome else returns false
return (str == inv);


package pal

func IsPal(s string) bool {
    mid := len(s) / 2
    last := len(s) - 1
    for i := 0; i < mid; i++ {
        if s[i] != s[last-i] {
            return false
        }
    }
    return true
}


package main

import (
	"fmt"
	"os"
	"strconv"
)

func gen_part(n, res []int, pos int) {
	if pos == len(res) {
		x := make([][]int, len(n))
		for i, c := range res {
			x[c] = append(x[c], i+1)
		}

		fmt.Println(x)
		return
	}

	for i := range n {
		if n[i] == 0 {
			continue
		}
		n[i], res[pos] = n[i]-1, i
		gen_part(n, res, pos+1)
		n[i]++
	}
}

func ordered_part(n_parts []int) {
	fmt.Println("Ordered", n_parts)

	sum := 0
	for _, c := range n_parts {
		sum += c
	}

	gen_part(n_parts, make([]int, sum), 0)
}

func main() {
	if len(os.Args) < 2 {
		ordered_part([]int{2, 0, 2})
		return
	}
	n := make([]int, len(os.Args)-1)
	var err error
	for i, a := range os.Args[1:] {
		n[i], err = strconv.Atoi(a)
		if err != nil {
			fmt.Println(err)
			return
		}
		if n[i] < 0 {
			fmt.Println("negative partition size not meaningful")
			return
		}
	}
	ordered_part(n)
}


def isPalindrome = { String s ->
    s == s?.reverse()
}


   result = Palindrome( "In girum imus nocte et consumimur igni" ) ! returns 1
END

FUNCTION Palindrome(string)
   CHARACTER string, CopyOfString

   L = LEN(string)
   ALLOCATE(CopyOfString, L)
   CopyOfString = string
   EDIT(Text=CopyOfString, UpperCase=L)
   L = L - EDIT(Text=CopyOfString, End, Left=' ', Delete, DO=L) ! EDIT returns number of deleted spaces

   DO i = 1, L/2
     Palindrome = CopyOfString(i) == CopyOfString(L - i + 1)
     IF( Palindrome == 0 ) RETURN
   ENDDO
END


def partitions = { int... sizes ->
    int n = (sizes as List).sum()
    def perms = n == 0 ? [[]] : (1..n).permutations()
    Set parts = perms.collect { p -> sizes.collect { s -> (0..<s).collect { p.pop() } as Set } }
    parts.sort{ a, b ->
        if (!a) return 0
    def comp = [a,b].transpose().find { aa, bb -> aa != bb }
    if (!comp) return 0
    def recomp = comp.collect{ it as List }.transpose().find { aa, bb -> aa != bb }
        if (!recomp) return 0
        return recomp[0] <=> recomp[1]
    }
}


import Data.List ((\\))

comb :: Int -> [a] -> [[a]]
comb 0 _      = [[]]
comb _ []     = []
comb k (x:xs) = map (x:) (comb (k-1) xs) ++ comb k xs

partitions :: [Int] -> [[[Int]]]
partitions xs = p [1..sum xs] xs
    where p _ []      = [[]]
          p xs (k:ks) = [ cs:rs | cs <- comb k xs, rs <- p (xs \\ cs) ks ]

main = print $ partitions [2,0,2]


procedure main(arglist)
every writes(s := !arglist) do write( if palindrome(s) then " is " else " is not", " a palindrome.")
end


Text isPalindrome? = method(self chars == self chars reverse)


(function () {
  'use strict';

  // [n] -> [[[n]]]
  function partitions(a1, a2, a3) {
    var n = a1 + a2 + a3;

    return combos(range(1, n), n, [a1, a2, a3]);
  }

  function combos(s, n, xxs) {
    if (!xxs.length) return [[]];

    var x = xxs[0],
        xs = xxs.slice(1);

    return mb( choose(s, n, x),                 function (l_rest) {
    return mb( combos(l_rest[1], (n - x), xs),  function (r) {
      // monadic return/injection requires 1 additional
      // layer of list nesting:
      return [ [l_rest[0]].concat(r) ];

    })});
  }

  function choose(aa, n, m) {
    if (!m) return [[[], aa]];

    var a = aa[0],
        as = aa.slice(1);

    return n === m ? (
      [[aa, []]]
    ) : (
      choose(as, n - 1, m - 1).map(function (xy) {
        return [[a].concat(xy[0]), xy[1]];
      }).concat(choose(as, n - 1, m).map(function (xy) {
        return [xy[0], [a].concat(xy[1])];
      }))
    );
  }

  // GENERIC

  // Monadic bind (chain) for lists
  function mb(xs, f) {
    return [].concat.apply([], xs.map(f));
  }

  // [m..n]
  function range(m, n) {
    return Array.apply(null, Array(n - m + 1)).map(function (x, i) {
      return m + i;
    });
  }

  // EXAMPLE

  return partitions(2, 0, 2);

})();


public static boolean pali(String testMe){
	StringBuilder sb = new StringBuilder(testMe);
	return testMe.equals(sb.reverse().toString());
}


function isPalindrome(str) {
  return str === str.split("").reverse().join("");
}

console.log(isPalindrome("ingirumimusnocteetconsumimurigni"));


# Generate a stream of the distinct combinations of r items taken from the input array.
def combination(r):
  if r > length or r < 0 then empty
  elif r == length then .
  else  ( [.[0]] + (.[1:]|combination(r-1))),
        ( .[1:]|combination(r))
  end;

# Input: a mask, that is, an array of lengths.
# Output: a stream of the distinct partitions defined by the mask.
def partition:

  # partition an array of entities, s, according to a mask presented as input:
  def p(s):
    if length == 0 then []
    else . as $mask
    | (s | combination($mask[0])) as $c
    | [$c] + ($mask[1:] | p(s - $c))
    end;
 . as $mask | p( [range(1; 1 + ($mask|add))] );


using Combinatorics

function masked(mask, lis)
    combos = []
    idx = 1
    for step in mask
        if(step < 1)
            push!(combos, Array{Int,1}[])
        else
            push!(combos, sort(lis[idx:idx+step-1]))
            idx += step
        end
    end
    Array{Array{Int, 1}, 1}(combos)
end

function orderedpartitions(mask)
    tostring(masklis) = replace("$masklis", r"Array{Int\d?\d?,1}|Int\d?\d?", "")
    join([tostring(lis) for lis in unique([masked(mask, p)
                        for p in permutations(1:sum(mask))])], "\n")
end

println(orderedpartitions([2, 0, 2]))
println(orderedpartitions([1, 1, 1]))


// version 1.1.3

fun nextPerm(perm: IntArray): Boolean {
    val size = perm.size
    var k = -1
    for (i in size - 2 downTo 0) {
        if (perm[i] < perm[i + 1]) {
            k = i
            break
        }
    }
    if (k == -1) return false  // last permutation
    for (l in size - 1 downTo k) {
        if (perm[k] < perm[l]) {
           val temp = perm[k]
           perm[k] = perm[l]
           perm[l] = temp
           var m = k + 1
           var n = size - 1
           while (m < n) {
               val temp2 = perm[m]
               perm[m++] = perm[n]
               perm[n--] = temp2
           }
           break
        }
    }
    return true
}

fun List<Int>.isMonotonic(): Boolean {
    for (i in 1 until this.size) {
        if (this[i] < this[i - 1]) return false
    }
    return true
}

fun main(args: Array<String>) {
    val sizes = args.map { it.toInt() }
    println("Partitions for $sizes:\n[")
    val totalSize = sizes.sum()
    val perm = IntArray(totalSize) { it + 1 }

    do {
        val partition = mutableListOf<List<Int>>()
        var sum = 0
        var isValid = true
        for (size in sizes) {
            if (size == 0) {
                partition.add(emptyList<Int>())
            }
            else if (size == 1) {
                partition.add(listOf(perm[sum]))
            }
            else {
                val sl = perm.slice(sum until sum + size)
                if (!sl.isMonotonic()) {
                    isValid = false
                    break
                }
                partition.add(sl)
            }
            sum += size
        }
        if (isValid) println("  $partition")
    }
    while (nextPerm(perm))
    println("]")
}


def palindrome: explode as $in | ($in|reverse) == $in;


/* Palindrome detection, in Jsish */
function isPalindrome(str:string, exact:boolean=true) {
  if (!exact) {
      str = str.toLowerCase();
      str = str.replace(/[ \t,;:!?.]/g, '');
  }
  return str === str.match(/./g).reverse().join('');
}

;isPalindrome('BUB');
;isPalindrome('CUB');
;isPalindrome('Bub');
;isPalindrome('Bub', false);
;isPalindrome('In girum imus nocte et consumimur igni', false);
;isPalindrome('A man, a plan, a canal; Panama!', false);
;isPalindrome('Never odd or even', false);

/*
=!EXPECTSTART!=
isPalindrome('BUB') ==> true
isPalindrome('CUB') ==> false
isPalindrome('Bub') ==> false
isPalindrome('Bub', false) ==> true
isPalindrome('In girum imus nocte et consumimur igni', false) ==> true
isPalindrome('A man, a plan, a canal; Panama!', false) ==> true
isPalindrome('Never odd or even', false) ==> true
=!EXPECTEND!=
*/


--- Create a list {1,...,n}.
local function range(n)
  local res = {}
  for i=1,n do
    res[i] = i
  end
  return res
end

--- Return true if the element x is in t.
local function isin(t, x)
  for _,x_t in ipairs(t) do
    if x_t == x then return true end
  end
  return false
end

--- Return the sublist from index u to o (inclusive) from t.
local function slice(t, u, o)
  local res = {}
  for i=u,o do
    res[#res+1] = t[i]
  end
  return res
end

--- Compute the sum of the elements in t.
-- Assume that t is a list of numbers.
local function sum(t)
  local s = 0
  for _,x in ipairs(t) do
    s = s + x
  end
  return s
end

--- Generate all combinations of t of length k (optional, default is #t).
local function combinations(m, r)
  local function combgen(m, n)
    if n == 0 then coroutine.yield({}) end
    for i=1,#m do
      if n == 1 then coroutine.yield({m[i]})
      else
        for m0 in coroutine.wrap(function() combgen(slice(m, i+1, #m), n-1) end) do
          coroutine.yield({m[i], unpack(m0)})
        end
      end
    end
  end
  return coroutine.wrap(function() combgen(m, r) end)
end

--- Generate a list of partitions into fized-size blocks.
local function partitions(...)
  local function helper(s, ...)
    local args = {...}
    if #args == 0 then return {% templatetag openvariable %}{% templatetag closevariable %} end
    local res = {}
    for c in combinations(s, args[1]) do
      local s0 = {}
      for _,x in ipairs(s) do if not isin(c, x) then s0[#s0+1] = x end end
      for _,r in ipairs(helper(s0, unpack(slice(args, 2, #args)))) do
        res[#res+1] = {{unpack(c)}, unpack(r)}
      end
    end
    return res
  end
  return helper(range(sum({...})), ...)
end

-- Print the solution
io.write "["
local parts = partitions(2,0,2)
for i,tuple in ipairs(parts) do
  io.write "("
  for j,set in ipairs(tuple) do
    io.write "{"
    for k,element in ipairs(set) do
      io.write(element)
      if k ~= #set then io.write(", ") end
    end
    io.write "}"
    if j ~= #tuple then io.write(", ") end
  end
  io.write ")"
  if i ~= #parts then io.write(", ") end
end
io.write "]"
io.write "\n"


// version 1.1.2

/* These functions deal automatically with Unicode as all strings are UTF-16 encoded in Kotlin */

fun isExactPalindrome(s: String) = (s == s.reversed())

fun isInexactPalindrome(s: String): Boolean {
    var t = ""
    for (c in s) if (c.isLetterOrDigit()) t += c
    t = t.toLowerCase()
    return t == t.reversed()
}

fun main(args: Array<String>) {
    val candidates = arrayOf("rotor", "rosetta", "step on no pets", "été")
    for (candidate in candidates) {
        println("'$candidate' is ${if (isExactPalindrome(candidate)) "an" else "not an"} exact palindrome")
    }
    println()
    val candidates2 = arrayOf(
         "In girum imus nocte et consumimur igni",
         "Rise to vote, sir",
         "A man, a plan, a canal - Panama!",
         "Ce repère, Perec"  // note: 'è' considered a distinct character from 'e'
    )
    for (candidate in candidates2) {
        println("'$candidate' is ${if (isInexactPalindrome(candidate)) "an" else "not an"} inexact palindrome")
    }
}


w[partitions_]:=Module[{s={},[email protected],list=partitions,k}, n=Length[list];
    While[n>0,s=Join[s,{Take[t,(k=First[list])]}];t=Drop[t,k];list=Rest[list];n--]; s]
m[p_]:=(Sort/@#)&/@(w[#,p]&/@Permutations[[email protected][p]])//Union


import algorithm, math, sequtils, strutils

type Partition = seq[seq[int]]

func isIncreasing(s: seq[int]): bool =
  ## Return true if the sequence is sorted in increasing order.
  var prev = 0
  for val in s:
    if prev >= val: return false
    prev = val
  result = true

iterator partitions(lengths: varargs[int]): Partition =
  ## Yield the partitions for lengths "lengths".

  # Build the list of slices to use for partitionning.
  var slices: seq[Slice[int]]
  var delta = -1
  var idx = 0
  for length in lengths:
    assert length >= 0, "lengths must not be negative."
    inc delta, length
    slices.add idx..delta
    inc idx, length

  # Build the partitions.
  let n = sum(lengths)
  var perm = toSeq(1..n)
  while true:

    block buildPartition:
      var part: Partition
      for slice in slices:
        let s = perm[slice]
        if not s.isIncreasing():
          break buildPartition
        part.add s
      yield part

    if not perm.nextPermutation():
      break

func toString(part: Partition): string =
  ## Return the string representation of a partition.
  result = "("
  for s in part:
    result.addSep(", ", 1)
    result.add '{' & s.join(", ") & '}'
  result.add ')'

when isMainModule:

  import os

  proc displayPermutations(lengths: varargs[int]) =
    ## Display the permutations.
    echo "Ordered permutations for (", lengths.join(", "), "):"
    for part in partitions(lengths):
      echo part.toString

  if paramCount() > 0:
    var args: seq[int]
    for param in commandLineParams():
      try:
        let val = param.parseInt()
        if val < 0: raise newException(ValueError, "")
        args.add val
      except ValueError:
        quit "Wrong parameter: " & param
    displayPermutations(args)

  else:
    displayPermutations(2, 0, 2)


use Thread 'async';
use Thread::Queue;

sub make_slices {
        my ($n, @avail) = (shift, @{ +shift });

        my ($q, @part, $gen);
        $gen = sub {
                my $pos = shift;        # where to start in the list
                if (@part == $n) {
                        # we accumulated enough for a partition, emit them and
                        # wait for main thread to pick them up, then back up
                        $q->enqueue(\@part, \@avail);
                        return;
                }

                # obviously not enough elements left to make a partition, back up
                return if (@part + @avail < $n);

                for my $i ($pos .. @avail - 1) {                # try each in turn
                        push @part, splice @avail, $i, 1;       # take one
                        $gen->($i);                             # go deeper
                        splice @avail, $i, 0, pop @part;        # put it back
                }
        };

        $q = new Thread::Queue;
        (async{ &$gen;                  # start the main work load
                $q->enqueue(undef)      # signal that there's no more data
        })->detach;     # let the thread clean up after itself, not my problem

        return $q;
}

my $qa = make_slices(4, [ 0 .. 9 ]);
while (my $a = $qa->dequeue) {
        my $qb = make_slices(2, $qa->dequeue);

        while (my $b = $qb->dequeue) {
                my $rb = $qb->dequeue;
                print "@$a | @$b | @$rb\n";
        }
}


val .ispal = f len(.s) > 0 and .s == s2s .s, len(.s)..1

val .tests = h{
    "": false,
    "z": true,
    "aha": true,
    "αηα": true,
    "αννα": true,
    "αννασ": false,
    "sees": true,
    "seas": false,
    "deified": true,
    "solo": false,
    "solos": true,
    "amanaplanacanalpanama": true,
    "a man a plan a canal panama": false,   # true if we remove spaces
    "ingirumimusnocteetconsumimurigni": true,
}

for .word in sort(keys .tests) {
    val .foundpal = .ispal(.word)
    writeln .word, ": ", .foundpal, if(.foundpal == .tests[.word]: ""; " (FAILED TEST)")
}


with javascript_semantics
requires("1.0.2")
function partitions(sequence s)
    integer l = length(s), N = sum(s)
    sequence pset = {}, -- eg s==={2,0,2} -> {1,1,3,3}
             rn = repeat(0,l) -- "" -> {{0,0},{},{0,0}}
    for i=1 to l do
        pset &= repeat(i,s[i])
        rn[i] = repeat(0,s[i])
    end for
    if pset={} then return {rn} end if -- edge case
    sequence res = permutes(pset,0)
    -- eg {1,1,3,3} means put 1,2 in [1], 3,4 in [3]
    -- .. {3,3,1,1} means put 1,2 in [3], 3,4 in [1]
    for i=1 to length(res) do
        sequence ri = res[i], -- a "flat" permute
               rdii = repeat(1,l) -- where per set
        integer rii = 0
        for j=1 to length(ri) do
            integer rdx = ri[j],    -- which set
                    rnx = rdii[rdx] -- wherein""
            rii += 1
            rn[rdx][rnx] = rii -- plant 1..N
            rdii[rdx] = rnx+1
        end for
        assert(rii=N)
        res[i] = deep_copy(rn)
    end for
    return res
end function

procedure test(sequence p)
    sequence q = partitions(p)
    string {ia,s} = iff(length(q)=1?{"is",""}:{"are","s"})
    printf(1,"There %s %,d ordered partion%s for %v:\n{%s}\n",
          {ia,length(q),s,p,join(shorten(q,"",5,"%v"),"\n ")})
end procedure
papply({{2,0,2},{1,1,1},{1,2,0,1},{1,2,3,4},{},{0,0,0}},test)


define ispalindrome(text::string) => {

	local(_text = string(#text)) // need to make copy to get rid of reference issues

	#_text -> replace(regexp(`(?:$|\W)+`), -ignorecase)

	local(reversed = string(#_text))
	#reversed -> reverse

	return #_text == #reversed
}

ispalindrome('Tätatät') // works with high ascii
ispalindrome('Hello World')

ispalindrome('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!')


print isPalindrome("In girum imus nocte et consumimur igni")
print isPalindrome(removePunctuation$("In girum imus nocte et consumimur igni", "S"))
print isPalindrome(removePunctuation$("In girum imus nocte et consumimur igni", "SC"))

function isPalindrome(string$)
    isPalindrome = 1
    for i = 1 to int(len(string$)/2)
        if mid$(string$, i, 1) <> mid$(string$, len(string$)-i+1, 1) then isPalindrome = 0 : exit function
    next i
end function

function removePunctuation$(string$, remove$)
    'P = remove puctuation.  S = remove spaces   C = remove case
    If instr(upper$(remove$), "C") then string$ = lower$(string$)
    If instr(upper$(remove$), "P") then removeCharacters$ = ",.!'()-&*?<>:;~[]{}"
    If instr(upper$(remove$), "S") then removeCharacters$ = removeCharacters$;" "

    for i = 1 to len(string$)
        if instr(removeCharacters$, mid$(string$, i, 1)) then string$ = left$(string$, i-1);right$(string$, len(string$)-i) : i = i - 1
    next i
    removePunctuation$ = string$
end function


(de partitions (Args)
   (let Lst (range 1 (apply + Args))
      (recur (Args Lst)
         (ifn Args
            '(NIL)
            (mapcan
               '((L)
                  (mapcar
                     '((R) (cons L R))
                     (recurse (cdr Args) (diff Lst L)) ) )
               (comb (car Args) Lst) ) ) ) ) )


from itertools import combinations

def partitions(*args):
    def p(s, *args):
        if not args: return [[]]
        res = []
        for c in combinations(s, args[0]):
            s0 = [x for x in s if x not in c]
            for r in p(s0, *args[1:]):
                res.append([c] + r)
        return res
    s = range(sum(args))
    return p(s, *args)

print partitions(2, 0, 2)


#lang racket
(define (comb k xs)
  (cond [(zero? k)  (list (cons '() xs))]
        [(null? xs) '()]
        [else (append (for/list ([cszs (comb (sub1 k) (cdr xs))])
                        (cons (cons (car xs) (car cszs)) (cdr cszs)))
                      (for/list ([cszs (comb k (cdr xs))])
                        (cons (car cszs) (cons (car xs) (cdr cszs)))))]))
(define (partitions xs)
  (define (p xs ks)
    (if (null? ks)
      '(())
      (for*/list ([cszs (comb (car ks) xs)] [rs (p (cdr cszs) (cdr ks))])
        (cons (car cszs) rs))))
  (p (range 1 (add1 (foldl + 0 xs))) xs))

(define (run . xs)
  (printf "partitions~s:\n" xs)
  (for ([x (partitions xs)]) (printf "  ~s\n" x))
  (newline))

(run 2 0 2)
(run 1 1 1)


sub partition(@mask is copy) {
    my @op;
    my $last = [+] @mask or return [] xx 1;
    for @mask.kv -> $k, $v {
        next unless $v;
        temp @mask[$k] -= 1;
        for partition @mask -> @p {
            @p[$k].push: $last;
            @op.push: @p;
        }
    }
    return @op;
}

.say for reverse partition [2,0,2];


function palindrome txt exact
    if exact is empty or exact is not false then
        set caseSensitive to true  --default is false
    else
        replace space with empty in txt
        put lower(txt) into txt
    end if
    return txt is reverse(txt)
end palindrome

function reverse str
    repeat with i = the length of str down to 1
        put byte i of str after revstr
    end repeat
    return revstr
end reverse


to palindrome? :w
  output equal? :w reverse :w
end


function ispalindrome(s) return s == string.reverse(s) end