/*REXX program renders a  graphical pattern  by  coloring  each pixel   with   x XOR y  */
/*─────────────────────────────────────────  from an arbitrary constructed color table. */
rows= 2                                          /*the number of rows in the color table*/
cols= 5                                          /* "     "    " cols  "  "    "     "  */
        do row  =0  for rows*3                   /*construct a color table, size  25x50.*/
          do col=0  for cols*3
                              $= (row+col) // 255
          @.row.col= x2b( d2x($+0, 2) )  ||,     /*ensure $ is converted──►2 hex nibbles*/
                     x2b( d2x($+1, 2) )  ||,
                     x2b( d2x($+2, 2) )
          end   /*col*/                          /* [↑]  construct a three-byte pixel.  */
        end     /*row*/

        do   x=0  for cols                       /*create a graphical pattern with XORs.*/
          do y=0  for rows
          @.x.y= bitxor(@.x, @.y)                /*renders 3 bytes (a pixel) at a time. */
          end   /*y*/
        end     /*x*/                            /*stick a fork in it,  we're all done. */


# Project : Munching squares

load "guilib.ring"

paint = null

new qapp
        {
        win1 = new qwidget() {
                  setwindowtitle("Archimedean spiral")
                  setgeometry(100,100,500,600)
                  label1 = new qlabel(win1) {
                              setgeometry(10,10,400,400)
                              settext("")
                  }
                  new qpushbutton(win1) {
                          setgeometry(150,500,100,30)
                          settext("draw")
                          setclickevent("draw()")
                  }
                  show()
        }
        exec()
        }

func draw
        p1 = new qpicture()
               color = new qcolor() {
               setrgb(0,0,255,255)
        }
        pen = new qpen() {
                 setcolor(color)
                 setwidth(1)
        }
        paint = new qpainter() {
                  begin(p1)
                  setpen(pen)

        w = 100
        for x = 0 to w
             for y = 0 to w
                   b = (x ^ y)
                   color = new qcolor()
                   color.setrgb(255 -b,b /2,b,255)
                   pen.setcolor(color)
                   setpen(pen)
                   drawpoint(x,w -y -1)
             next
         next

        endpaint()
        }
        label1 { setpicture(p1) show() }
        return


load 'raster_graphics.rb'

class Pixmap
  def self.xor_pattern(width, height, rgb1, rgb2)
    # create colour table
    size = 256
    colours = Array.new(size) do |i|
      RGBColour.new(
        (rgb1.red + (rgb2.red - rgb1.red) * i / size),
        (rgb1.green + (rgb2.green - rgb1.green) * i / size),
        (rgb1.blue + (rgb2.blue - rgb1.blue) * i / size),
      )
    end

    # create the image
    pixmap = new(width, height)
    pixmap.each_pixel do |x, y|
      pixmap[x,y] = colours[(x^y)%size]
    end
    pixmap
  end
end

img = Pixmap.xor_pattern(384, 384, RGBColour::RED, RGBColour::YELLOW)
img.save_as_png('xorpattern.png')


w = 100
graphic #g, w,w
for x = 0 to w
  for y = 0 to w
    b = (x xor y) and 255
    #g color(255 -b,b /2,b)
    #g "set "; x; " "; w -y -1
  next y
next x
render #g
#g "flush"


extern crate image;

use image::{ImageBuffer, Pixel, Rgb};

fn main() {
    let mut img = ImageBuffer::new(256, 256);

    for x in 0..256 {
        for y in 0..256 {
            let pixel = Rgb::from_channels(0, x as u8 ^ y as u8, 0, 0);
            img.put_pixel(x, y, pixel);
        }
    }

    let _ = img.save("output.png");
}


import scala.swing.Swing.pair2Dimension
import scala.swing.{Color, Graphics2D, MainFrame, Panel, SimpleSwingApplication}

object XorPattern extends SimpleSwingApplication {

  def top = new MainFrame {
    preferredSize = (300, 300)
    title = "Rosetta Code >>> Task: Munching squares | Language: Scala"
    contents = new Panel {

      protected override def paintComponent(g: Graphics2D) = {
        super.paintComponent(g)
        for {
          y <- 0 until size.getHeight.toInt
          x <- 0 until size.getWidth.toInt
        } {
          g.setColor(new Color(0, (x ^ y) % 256, 0))
          g.drawLine(x, y, x, y)
        }
      }
    }

    centerOnScreen()
  }
}


require('Imager')

var img = %O<Imager>.new(xsize => 256, ysize => 256)

for y=(^256), x=(^256) {
    var rgb = [(255 - x - y).abs, (255-x)^y, x^(255-y)]
    img.setpixel(x => x, y => y, color => rgb)
}

img.write(file => 'xor.png')


package require Tk

proc xorImage {img table} {
    set data {}
    set h [image height $img]
    set w [image width $img]
    for {set y 0} {$y < $h} {incr y} {
	set row {}
	for {set x 0} {$x < $w} {incr x} {
	    lappend row [lindex $table [expr {($x^$y) % [llength $table]}]]
	}
	lappend data $row
    }
    $img put $data
}
proc inRange {i f t} {expr {$f + ($t-$f)*$i/255}}
proc mkTable {rf rt gf gt bf bt} {
    for {set i 0} {$i < 256} {incr i} {
	lappend tbl [format "#%02x%02x%02x" \
	    [inRange $i $rf $rt] [inRange $i $gf $gt] [inRange $i $bf $bt]]
    }
    return $tbl
}

set img [image create photo -width 512 -height 512]
xorImage $img [mkTable 0 255 64 192 255 0]
pack [label .l -image $img]


PROGRAM:XORPATT
" •.-,+-°-1+o*:πOX"→Str1

ClrHome

{0,0,0,0}→L1
{0,0,0,0)→L2

For(I,1,8,1)
For(J,1,16,1)
J→A
I→B

If A>8
Then
A-8→A
1→L1(1)
Else
0→L1(1)
End

If A>4
Then
A-4→A
1→L1(2)
Else
0→L1(2)
End

If A>2
Then
A-2→A
1→L1(3)
Else
0→L1(3)
End

If A>1
Then
1→L1(4)
Else
0→L1(4)
End

0→L2(1)

If B>4
Then
B-4→B
1→L2(2)
Else
0→L2(2)
End

If B>2
Then
B-2→B
1→L2(3)
Else
0→L2(3)
End

If B>1
Then
1→L2(4)
Else
0→L2(4)
End

L1≠L2→L3
8L3(1)+4L3(2)+2L3(3)+L3(4)→C
Output(I,J,sub(Str1,C+1,1))

End
End
Pause


' Munching squares - 27/07/2018
Public Class MunchingSquares
    Const xsize = 256
    Dim BMP As New Drawing.Bitmap(xsize, xsize)
    Dim GFX As Graphics = Graphics.FromImage(BMP)

    Private Sub MunchingSquares_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint
        'draw
        Dim MyGraph As Graphics = Me.CreateGraphics
        Dim nColor As Color
        Dim i, j, cp As Integer
        xPictureBox.Image = BMP
        For i = 0 To xsize - 1
            For j = 0 To xsize - 1
                cp = i Xor j
                nColor = Color.FromArgb(cp, 0, cp)
                BMP.SetPixel(i, j, nColor)
            Next j
        Next i
    End Sub 'Paint

End Class


import "graphics" for Canvas, Color
import "dome" for Window

class Game {
    static init() {
        Window.title = "Munching squares"
        var w = 512
        var h = 512
        Window.resize(w, h)
        Canvas.resize(w, h)
        for (x in 0...w) {
            for (y in 0...h) {
                var c = (x ^ y) & 255
                Canvas.pset(x, y, Color.rgb(255-c, (c/2).floor, c))
            }
        }
    }

    static update() {}

    static draw(alpha) {}
}


include c:\cxpl\codes;          \intrinsic 'code' declarations
int X, Y;
[SetVid($101);                  \set 640x480 graphics with 8-bit color
port($3C8):= 0;                 \set color registers with beautiful shades
for X:= 0 to 256-1 do
        [port($3C9):= X>>1;     \red
         port($3C9):= X>>3;     \green
         port($3C9):= X;        \blue
         ];
for Y:= 0 to 256-1 do           \"color table" is array of 256 registers
    for X:= 0 to 256-1 do
        Point(X, Y, X|Y);       \"|" = XOR, not OR which is "!"
X:= ChIn(1);                    \wait for keystroke
SetVid(3);                      \restore normal text mode
]


w = 256

open window w, w

For x = 0 To w-1
    For y = 0 To w-1
        r =and(xor(x, y), 255)
        color r, and(r*2, 255), and(r*3, 255)
        dot x, y
    Next
Next


fcn muncher{
   bitmap:=PPM(256,256);
   coolness:=(1).random(0x10000);  // 55379, 18180, 40, 51950, 57619, 43514, 65465
   foreach y,x in ([0 .. 255],[0 .. 255]){
      b:=x.bitXor(y);	// shades of blue
//      rgb:=b*coolness;                 // kaleidoscopic image
//      rgb:=(b*coolness + b)*coolness + b;  // more coolness
      rgb:=(b*0x10000 + b)*0x10000 + b;  // copy ADA image
      bitmap[x,y]=rgb;
   }
   bitmap.write(File("foo.ppm","wb"));
}();


L(i) 5000
   I i == sum(String(i).map(x -> Int(x) ^ Int(x)))
      print(i)


*        Munchausen numbers        16/03/2019
MUNCHAU  CSECT
         USING  MUNCHAU,R12        base register
         LR     R12,R15            set addressability
         L      R3,=F'5000'        for do i=1 to 5000
         LA     R6,1               i=1
LOOPI    SR     R10,R10              s=0
         LR     R0,R6                ii=i
         LA     R11,4                for do j=1 to 4
         LA     R7,P10               j=1
LOOPJ    L      R8,0(R7)               d=p10(j)
         LR     R4,R0                  ii
         SRDA   R4,32                  ~
         DR     R4,R8                  (n,r)=ii/d
         SLA    R5,2                   ~
         L      R1,POW(R5)             pow(n+1)
         AR     R10,R1                 s=s+pow(n+1)
         LR     R0,R4                  ii=r
         LA     R7,4(R7)               j++
         BCT    R11,LOOPJ            enddo j
         CR     R10,R6               if s=i
         BNE    SKIP                 then
         XDECO  R6,PG                  edit i
         XPRNT  PG,L'PG                print i
SKIP     LA     R6,1(R6)             i++
         BCT    R3,LOOPI           enddo i
         BR     R14                return to caller
POW      DC     F'0',F'1',F'4',F'27',F'256',F'3125',4F'0'
P10      DC     F'1000',F'100',F'10',F'1'
PG       DC     CL12' '            buffer
         REGEQU
         END    MUNCHAU


putch:	equ	2	; CP/M syscall to print character
puts:	equ	9	; CP/M syscall to print string
	org	100h
	lxi	b,0500h	; B C D E hold 4 digits of number
	lxi	d,0000h	; we work backwards from 5000
	lxi	h,-5000	; HL holds negative binary representation of number
test:	push	h	; Keep current number
	push	d	; Keep last two digits (to use DE as scratch register)
	push	h 	; Keep current number (to test against)
	lxi	h,0	; Digit power sum = 0
	mov	a,b
	call	addap
	mov	a,c
	call	addap
	mov	a,d
	call 	addap
	mov	a,e
	call 	addap
	xra	a	; Correct for leading zeroes
	ora	b
	jnz	calc
	dcx	h
	ora	c
	jnz	calc
	dcx	h
	ora	d
	jnz 	calc
	dcx	h
calc:	pop	d	; Load current number (as negative) into DE
	dad	d 	; Add to sum of digits (if equal, should be 0)
	mov	a,h	; See if they are equal
	ora	l
	pop	d	; Restore last two digits
	pop	h	; Restore current number
	jnz	next	; If not equal, this is not a Munchhausen number
	mov	a,b	; Otherwise, print the number
	call	pdgt
	mov	a,c
	call	pdgt
	mov	a,d
	call	pdgt
	mov	a,e
	call	pdgt
	call	pnl
next:	inx	h	; Increment negative binary representation
	mvi	a,5
	dcr	e	; Decrement last digit
	jp	test	; If not negative, try next number
	mov	e,a	; Otherwise, set to 5,
	inx	h	; Add 4 extra to HL,
	inx	h
	inx	h
	inx	h
	dcr	d
	jp	test
	mov	d,a
	push	d	; Add 40 extra to HL,
	lxi	d,40
	dad	d
	pop	d
	dcr 	c
	jp	test
	mov	c,a
	push	d	; Add 400 extra to HL,
	lxi	d,400
	dad	d
	pop	d
	dcr	b
	jp	test
	ret		; When B<0, we're done
	;;;	Print A as digit
pdgt:	adi	'0'
	push	b	; Save all registers (CP/M tramples them)
	push	d
	push	h
	mov	e,a	; Print character
	mvi	c,putch
	call	5
restor:	pop	h	; Restore registers
	pop	d
	pop 	b
	ret
	;;;	Print newline
pnl:	push	b	; Save all registers
	push	d
	push	h
	lxi	d,nl	; Print newline
	mvi	c,puts
	call	5
	jmp	restor	; Restore registers
nl:	db	13,10,'$'
	;;;	Add A^A to HL
addap:	push	d	; Keep DE
	push	h	; Keep HL
	add	a	; A *= 2 (entries are 2 bytes wide)
	mvi	d,0	; DE = lookup table index
	mov	e,a
	lxi	h,dpow	; Calculate table address
	dad	d
	mov	e,m	; Load low byte into E
	inx	h
	mov	d,m	; Load high byte into D
	pop	h	; Retrieve old HL
	dad	d	; Add power
	pop	d	; Restore DE
	ret
dpow:	dw	1,1,4,27,256,3125	; 0^0 to 5^5 lookup table


;there are considered digits 0-5 because 6^6>5000
DEFINE MAXDIGIT="5"
INT ARRAY powers(MAXDIGIT+1)

INT FUNC Power(BYTE x)
  INT res
  BYTE i

  IF x=0 THEN RETURN (0) FI
  res=1
  FOR i=0 TO x-1
  DO
    res==*x
  OD
RETURN (res)

BYTE FUNC IsMunchausen(INT x)
  INT sum,tmp
  BYTE d

  tmp=x sum=0
  WHILE tmp#0
  DO
    d=tmp MOD 10
    IF d>MAXDIGIT THEN
      RETURN (0)
    FI
    sum==+powers(d)
    tmp==/10
  OD
  IF sum=x THEN
    RETURN (1)
  FI
RETURN (0)

PROC Main()
  INT i

  FOR i=0 TO MAXDIGIT
  DO
    powers(i)=Power(i)
  OD
  FOR i=1 TO 5000
  DO
    IF IsMunchausen(i) THEN
      PrintIE(i)
    FI
  OD
RETURN


with Ada.Text_IO;

procedure Munchausen is

   function Is_Munchausen (M : in Natural) return Boolean is
      Table : constant array (Character range '0' .. '9') of Natural :=
        (0**0, 1**1, 2**2, 3**3, 4**4,
         5**5, 6**6, 7**7, 8**8, 9**9);
      Image : constant String := M'Image;
      Sum   : Natural := 0;
   begin
      for I in Image'First + 1 .. Image'Last loop
         Sum := Sum + Table (Image (I));
      end loop;
      return Image = Sum'Image;
   end Is_Munchausen;

begin
   for M in 1 .. 5_000 loop
      if Is_Munchausen (M) then
         Ada.Text_IO.Put (M'Image);
      end if;
   end loop;
   Ada.Text_IO.New_Line;
end Munchausen;


# Find Munchausen Numbers between 1 and 5000                                        #
# note that 6^6 is 46 656 so we only need to consider numbers consisting of 0 to 5   #

# table of Nth powers - note 0^0 is 0 for Munchausen numbers, not 1                 #
[]INT nth power = ([]INT( 0, 1, 2 * 2, 3 * 3 * 3, 4 * 4 * 4 * 4, 5 * 5 * 5 * 5 * 5 ))[ AT 0 ];

INT d1 := 0; INT d1 part := 0;
INT d2 := 0; INT d2 part := 0;
INT d3 := 0; INT d3 part := 0;
INT d4 := 1;
WHILE d1 < 6 DO
    INT number           = d1 part + d2 part + d3 part + d4;
    INT digit power sum := nth power[ d1 ]
                         + nth power[ d2 ]
                         + nth power[ d3 ]
                         + nth power[ d4 ];
    IF digit power sum = number THEN
        print( ( whole( number, 0 ), newline ) )
    FI;
    d4 +:= 1;
    IF d4 > 5 THEN
        d4       := 0;
        d3      +:= 1;
        d3 part +:= 10;
        IF d3 > 5 THEN
            d3       := 0;
            d3 part  := 0;
            d2      +:= 1;
            d2 part +:= 100;
            IF d2 > 5 THEN
                d2       := 0;
                d2 part  := 0;
                d1      +:= 1;
                d1 part +:= 1000;
            FI
        FI
    FI
OD


% Find Munchausen Numbers between 1 and 5000                                         %
% note that 6^6 is 46 656 so we only need to consider numbers consisting of 0 to 5   %
begin

    % table of nth Powers - note 0^0 is 0 for Munchausen numbers, not 1              %
    integer array nthPower( 0 :: 5 );
    integer d1, d2, d3, d4, d1Part, d2Part, d3Part;
    nthPower( 0 ) := 0;             nthPower( 1 ) := 1;
    nthPower( 2 ) := 2 * 2;         nthPower( 3 ) := 3 * 3 * 3;
    nthPower( 4 ) := 4 * 4 * 4 * 4; nthPower( 5 ) := 5 * 5 * 5 * 5 * 5;
    d1 := d2 := d3 := d1Part := d2Part := d3Part := 0;
    d4 := 1;
    while d1 < 6 do begin
        integer number, digitPowerSum;
        number        := d1Part + d2Part + d3Part + d4;
        digitPowerSum := nthPower( d1 )
                       + nthPower( d2 )
                       + nthPower( d3 )
                       + nthPower( d4 );
        if digitPowerSum = number then begin
            write( i_w := 1, number )
        end;
        d4 := d4 + 1;
        if d4 > 5 then begin
            d4     := 0;
            d3     := d3 + 1;
            d3Part := d3Part + 10;
            if d3 > 5 then begin
                d3     := 0;
                d3Part := 0;
                d2     := d2 + 1;
                d2Part := d2Part + 100;
                if d2 > 5 then begin
                    d2     := 0;
                    d2Part := 0;
                    d1     := d1 + 1;
                    d1Part := d1Part + 1000;
                end
            end
        end
    end

end.


------------------- MUNCHAUSEN NUMBER ? --------------------

-- isMunchausen :: Int -> Bool
on isMunchausen(n)

    -- digitPowerSum :: Int -> Character -> Int
    script digitPowerSum
        on |λ|(a, c)
            set d to c as integer
            a + (d ^ d)
        end |λ|
    end script

    (class of n is integer) and ¬
        n = foldl(digitPowerSum, 0, characters of (n as string))

end isMunchausen

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

    filter(isMunchausen, enumFromTo(1, 5000))

    --> {1, 3435}

end run

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

-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
    if m ≤ n then
        set lst to {}
        repeat with i from m to n
            set end of lst to i
        end repeat
        lst
    else
        {}
    end if
end enumFromTo

-- filter :: (a -> Bool) -> [a] -> [a]
on filter(p, xs)
    tell mReturn(p)
        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

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

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


munchausen?: function [n][
    n = sum map split to :string n 'digit [
        d: to :integer digit
        d^d
    ]
]

loop 1..5000 'x [
    if munchausen? x ->
        print x
]


Loop, 5000
{
	Loop, Parse, A_Index
		var += A_LoopField**A_LoopField
	if (var = A_Index)
		num .= var "`n"
	var := 0
}
Msgbox, %num%


# syntax: GAWK -f MUNCHAUSEN_NUMBERS.AWK
BEGIN {
    for (i=1; i<=5000; i++) {
      sum = 0
      for (j=1; j<=length(i); j++) {
        digit = substr(i,j,1)
        sum += digit ^ digit
      }
      if (i == sum) {
        printf("%d\n",i)
      }
    }
    exit(0)
}


10 DEF FN P(X)=INT(X^X*SGN(X))
20 FOR I=0 TO 5
30 FOR J=0 TO 5
40 FOR K=0 TO 5
50 FOR L=0 TO 5
60 M=FN P(I)+FN P(J)+FN P(K)+FN P(L)
70 N=1000*I+100*J+10*K+L
80 IF M=N AND M>0 THEN PRINT M
90 NEXT L
100 NEXT K
110 NEXT J
120 NEXT I


REM >munchausen
FOR i% = 0 TO 5
  FOR j% = 0 TO 5
    FOR k% = 0 TO 5
      FOR l% = 0 TO 5
        m% = FNexp(i%) + FNexp(j%) + FNexp(k%) + FNexp(l%)
        n% = 1000 * i% + 100 * j% + 10 * k% + l%
        IF m% = n% AND m% > 0 THEN PRINT m%
      NEXT
    NEXT
  NEXT
NEXT
END
:
DEF FNexp(x%)
IF x% = 0 THEN
  = 0
ELSE
  = x% ^ x%


Dgts ← •Fmt-'0'˙
IsMnch ← ⊢=+´∘(⋆˜ Dgts)
IsMnch¨⊸/ 1+↕5000


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

int main() {
    for (int i = 1; i < 5000; i++) {
        // loop through each digit in i
        // e.g. for 1000 we get 0, 0, 0, 1.
        int sum = 0;
        for (int number = i; number > 0; number /= 10) {
            int digit = number % 10;
            // find the sum of the digits
            // raised to themselves
            sum += pow(digit, digit);
        }
        if (sum == i) {
            // the sum is equal to the number
            // itself; thus it is a
            // munchausen number
            printf("%i\n", i);
        }
    }
    return 0;
}


Func<char, int> toInt = c => c-'0';

foreach (var i in Enumerable.Range(1,5000)
	.Where(n => n == n.ToString()
		.Sum(x => Math.Pow(toInt(x), toInt(x)))))
	Console.WriteLine(i);


#include <math.h>
#include <iostream>

unsigned pwr[10];

unsigned munch( unsigned i ) {
    unsigned sum = 0;
    while( i ) {
        sum += pwr[(i % 10)];
        i /= 10;
    }
    return sum;
}

int main( int argc, char* argv[] ) {
    for( int i = 0; i < 10; i++ )
        pwr[i] = (unsigned)pow( (float)i, (float)i );
    std::cout << "Munchausen Numbers\n==================\n";
    for( unsigned i = 1; i < 5000; i++ )
        if( i == munch( i ) ) std::cout << i << "\n";
    return 0;
}


(ns async-example.core
  (:require [clojure.math.numeric-tower :as math])
  (:use [criterium.core])
  (:gen-class))

(defn get-digits [n]
  " Convert number of a list of digits  (e.g. 545 -> ((5), (4), (5)) "
  (map #(Integer/valueOf (str %)) (String/valueOf n)))

(defn sum-power [digits]
  " Convert digits such as abc... to a^a + b^b + c^c ..."
  (let [digits-pwr (fn [n]
                     (apply + (map #(math/expt % %) digits)))]
    (digits-pwr digits)))

(defn find-numbers [max-range]
  " Filters for Munchausen numbers "
  (->>
    (range 1 (inc max-range))
    (filter #(= (sum-power (get-digits %)) %))))

(println (find-numbers 5000))


digits = iter (n: int) yields (int)
    while n>0 do
        yield(n//10)
        n := n/10
    end
end digits

munchausen = proc (n: int) returns (bool)
    k: int := 0
    for d: int in digits(n) do
        % Note: 0^0 is to be regarded as 0
        if d~=0 then k := k + d ** d end
    end
    return(n = k)
end munchausen

start_up = proc ()
    po: stream := stream$primary_output()
    for i: int in int$from_to(1,5000) do
        if munchausen(i) then stream$putl(po, int$unparse(i)) end
    end
end start_up


;;; check4munch maximum &optional b
;;; Return a list with all Munchausen numbers less then or equal to maximum.
;;; Checks are done in base b (<=10, dpower is the limiting factor here).
(defun check4munch (maximum &optional (base 10))
  (do ((n 1 (1+ n))
       (result NIL (if (munchp n base) (cons n result) result)))
      ((> n maximum)
       (nreverse result))))

;;;
;;; munchp n &optional b
;;; Return T if n is a Munchausen number in base b.
(defun munchp (n &optional (base 10))
   (if (= n (apply #'+ (mapcar #'dpower (n2base n base)))) T NIL))

;;; dpower d
;;; Returns d^d. I.e. the digit to the power of itself.
;;; 0^0 is set to 0. For discussion see e.g. the wikipedia entry.
;;; This function is mainly performance optimization.
(defun dpower (d)
  (aref #(0 1 4 27 256 3125 45556 823543 16777216 387420489) d))

;;; divmod a b
;;; Return (q,k) such that a = b*q + k and k>=0.
(defun divmod (a b)
  (let ((foo (mod a b)))
    (list (/ (- a foo) b) foo)))

;;; n2base n &optional b
;;; Return a list with the digits of n in base b representation.
(defun n2base (n &optional (base 10) (digits NIL))
  (if (zerop n) digits
                (let ((dm (divmod n base)))
                  (n2base (car dm) base (cons (cadr dm) digits)))))


       IDENTIFICATION DIVISION.
       PROGRAM-ID.  MUNCHAUSEN.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01 VARIABLES.
          03 CANDIDATE   PIC 9(4).
          03 DIGITS      PIC 9 OCCURS 4 TIMES, REDEFINES CANDIDATE.
          03 DIGIT       PIC 9.
          03 POWER-SUM   PIC 9(5).

       01 OUTPUT-LINE.
          03 OUT-NUM     PIC ZZZ9.

       PROCEDURE DIVISION.
       BEGIN.
           PERFORM MUNCHAUSEN-TEST VARYING CANDIDATE FROM 1 BY 1
               UNTIL CANDIDATE IS GREATER THAN 6000.
           STOP RUN.

       MUNCHAUSEN-TEST.
           MOVE ZERO TO POWER-SUM.
           MOVE 1 TO DIGIT.
           INSPECT CANDIDATE TALLYING DIGIT FOR LEADING '0'.
           PERFORM ADD-DIGIT-POWER VARYING DIGIT FROM DIGIT BY 1
               UNTIL DIGIT IS GREATER THAN 4.
           IF POWER-SUM IS EQUAL TO CANDIDATE,
               MOVE CANDIDATE TO OUT-NUM,
               DISPLAY OUTPUT-LINE.

       ADD-DIGIT-POWER.
           COMPUTE POWER-SUM =
                     POWER-SUM + DIGITS(DIGIT) ** DIGITS(DIGIT)


include "cowgol.coh";

sub digitPowerSum(n: uint16): (sum: uint32) is
    var powers: uint32[10] :=
        {1, 1, 4, 27, 256, 3125, 46656, 823543, 16777216, 387420489};

    sum := 0;
    loop
        sum := sum + powers[(n % 10) as uint8];
        n := n / 10;
        if n == 0 then break; end if;
    end loop;
end sub;

var n: uint16 := 1;
while n < 5000 loop
    if n as uint32 == digitPowerSum(n) then
        print_i16(n);
        print_nl();
    end if;
    n := n + 1;
end loop;


import std.stdio;

void main() {
    for (int i=1; i<5000; i++) {
        // loop through each digit in i
        // e.g. for 1000 we get 0, 0, 0, 1.
        int sum = 0;
        for (int number=i; number>0; number/=10) {
            int digit = number % 10;
            // find the sum of the digits
            // raised to themselves
            sum += digit ^^ digit;
        }
        if (sum == i) {
            // the sum is equal to the number
            // itself; thus it is a
            // munchausen number
            writeln(i);
        }
    }
}


[ O ~ S! d 0!=M L! d ^ + ] sM
[p] sp
[z d d lM x =p z 5001>L ] sL
lL x


defmodule Munchausen do
  @pow  for i <- 0..9, into: %{}, do: {i, :math.pow(i,i) |> round}

  def number?(n) do
    n == Integer.digits(n) |> Enum.reduce(0, fn d,acc -> @pow[d] + acc end)
  end
end

Enum.each(1..5000, fn i ->
  if Munchausen.number?(i), do: IO.puts i
end)


let toFloat x = x |> int |> fun n -> n - 48 |> float
let power x = toFloat x ** toFloat x |> int
let isMunchausen n = n = (string n |> Seq.map char |> Seq.map power |> Seq.sum)

printfn "%A" ([1..5000] |> List.filter isMunchausen)


USING: kernel math.functions math.ranges math.text.utils
prettyprint sequences ;

: munchausen? ( n -- ? )
    dup 1 digit-groups dup [ ^ ] 2map sum = ;

5000 [1,b] [ munchausen? ] filter .


 : dig.num                                       \ returns input number and the number of its digits ( n -- n n1 )
	 dup
	 0 swap
     begin
	 swap 1 + swap
	 dup 10 >= while
	 10 /
     repeat
	 drop ;

 : to.self                                        \ returns input number raised to the power of itself ( n -- n^n  )
	 dup 1 = if drop 1 else                   \ positive numbers only, zero and negative returns zero
	 dup 0 <= if drop 0 else
	 dup
         1 do
	 dup
	 loop
	 dup
	 1 do
	 *
         loop
	 then then ;

 : ten.to			                    \ ( n -- 10^n ) returns 1 for zero and negative
	 dup 0 <= if drop 1 else
	 dup 1 = if drop 10 else
	 10 swap
         1 do
	 10 *
         loop then then ;

 : zero.divmod                                       \ /mod that returns zero if number is zero
	  dup
	  0 = if drop 0
          else /mod
	  then ;

 : split.div                                         \ returns input number and its digits ( n -- n n1 n2 n3....)
	  dup 10 < if dup 0 else		     \ duplicates single digit numbers adds 0 for add.pow
	  dig.num			             \ provides number of digits
	  swap dup rot dup 1 - ten.to swap           \ stack juggling, ten raised to number of digits - 1...
          1 do                                       \ ... is the needed divisor, counter on top and ...
	  dup rot swap zero.divmod swap rot 10 /     \ ...division loop
          loop drop then ;

 : add.pow	  				     \ raises each number on the stack except last one to ...
	  to.self                                    \ ...the power of itself and adds them
	  depth					     \ needs at least 3 numbers on the stack
          2 do
	  swap to.self +
          loop ;

 : check.num
	 split.div add.pow ;

 : munch.num                                         \ ( n -- ) displays Munchausen numbers between 1 and n
         1 +
	 page
         1 do
         i check.num = if i . cr
         then loop ;


C MUNCHAUSEN NUMBERS - FORTRAN IV
      DO 2 I=1,5000
        IS=0
        II=I
        DO 1 J=1,4
          ID=10**(4-J)
          N=II/ID
          IR=MOD(II,ID)
          IF(N.NE.0) IS=IS+N**N
  1       II=IR
  2     IF(IS.EQ.I) WRITE(*,*) I
      END


' FB 1.05.0 Win64
' Cache n ^ n for the digits 1 to 9
' Note than 0 ^ 0 specially treated as 0 (not 1) for this purpose
Dim Shared powers(1 To 9) As UInteger
For i As UInteger = 1 To 9
  Dim power As UInteger = i
  For j As UInteger = 2 To i
     power *= i
  Next j
  powers(i) = power
Next i

Function isMunchausen(n As UInteger) As Boolean
  Dim p As UInteger = n
  Dim As UInteger digit, sum
  While p > 0
    digit = p Mod 10
    If digit > 0 Then sum += powers(digit)
    p \= 10
  Wend
  Return n = sum
End Function

Print "The Munchausen numbers between 0 and 500000000 are : "
For i As UInteger = 0 To 500000000
  If isMunchausen(i) Then Print i
Next

Print
Print "Press any key to quit"

Sleep


package main

import(
    "fmt"
    "math"
)

var powers [10]int

func isMunchausen(n int) bool {
    if n < 0 { return false }
    n64 := int64(n)
    nn  := n64
    var sum int64 = 0
    for nn > 0 {
        sum += int64(powers[nn % 10])
        if sum > n64 { return false }
        nn /= 10
    }
    return sum == n64
}

func main() {
    // cache n ^ n for n in 0..9, defining 0 ^ 0 = 0 for this purpose
    for i := 1; i <= 9; i++ {
        d := float64(i)
        powers[i] = int(math.Pow(d, d))
    }

    // check numbers 0 to 500 million
    fmt.Println("The Munchausen numbers between 0 and 500 million are:")
    for i := 0; i <= 500000000; i++ {
        if isMunchausen(i) { fmt.Printf("%d ", i) }
    }
    fmt.Println()
}


import Control.Monad (join)
import Data.List (unfoldr)

isMunchausen :: Integer -> Bool
isMunchausen =
  (==)
    <*> (sum . map (join (^)) . unfoldr digit)

digit 0 = Nothing
digit n = Just (r, q) where (q, r) = n `divMod` 10

main :: IO ()
main = print $ filter isMunchausen [1 .. 5000]


public class Main {
    public static void main(String[] args) {
        for(int i = 0 ; i <= 5000 ; i++ ){
            int val = String.valueOf(i).chars().map(x -> (int) Math.pow( x-48 ,x-48)).sum();
            if( i == val){
                System.out.println( i + " (munchausen)");
            }
        }
    }
}


for (let i of [...Array(5000).keys()]
	.filter(n => n == n.toString().split('')
	.reduce((a, b) => a+Math.pow(parseInt(b),parseInt(b)), 0)))
    console.log(i);


def sigma( stream ): reduce stream as $x (0; . + $x ) ;

def ismunchausen:
   def digits: tostring | split("")[] | tonumber;
   . == sigma(digits | pow(.;.));

# Munchausen numbers from 1 to 5000 inclusive:
range(1;5001) | select(ismunchausen)


println([n for n = 1:5000 if sum(d^d for d in digits(n)) == n])


// version 1.0.6

val powers = IntArray(10)

fun isMunchausen(n: Int): Boolean {
    if (n < 0) return false
    var sum = 0L
    var nn = n
    while (nn > 0) {
        sum += powers[nn % 10]
        if (sum > n.toLong()) return false
        nn /= 10
    }
    return sum == n.toLong()
}

fun main(args: Array<String>) {
   // cache n ^ n for n in 0..9, defining 0 ^ 0 = 0 for this purpose
   for (i in 1..9) powers[i] = Math.pow(i.toDouble(), i.toDouble()).toInt()

   // check numbers 0 to 500 million
   println("The Munchausen numbers between 0 and 500 million are:")
   for (i in 0..500000000) if (isMunchausen(i))print ("$i ")
   println()
}


{def munch
 {lambda {:w}
  {= :w {+ {S.map {{lambda {:w :i}
                           {pow {W.get :i :w} {W.get :i :w}}} :w}
                  {S.serie 0 {- {W.length :w} 1}}}}} }}
-> munch

{S.map {lambda {:i} {if {munch :i} then :i else}}
       {S.serie 1 5000}}
->
1
3435


# sum power of digits
val .spod = f(.n) fold f{+}, map(f (.x-'0') ^ (.x-'0'), s2cp toString .n)

# Munchausen
writeln "Answers: ", where f(.n) .n == .spod(.n), series 0..5000


function isMunchausen (n)
    local sum, nStr, digit = 0, tostring(n)
    for pos = 1, #nStr do
        digit = tonumber(nStr:sub(pos, pos))
        sum = sum + digit ^ digit
    end
    return sum == n
end

-- alternative, faster version based on the C version,
-- avoiding string manipulation, for Lua 5.3 or higher
local function isMunchausen (n)
    local sum, digit, acc = 0, 0, n
    while acc > 0 do
        digit = acc % 10.0
        sum = sum + digit ^ digit
        acc = acc // 10 -- integer div
    end
    return sum == n
end

for i = 1, 5000 do
    if isMunchausen(i) then print(i) end
end


Module Munchausen {
      Inventory p=0:=0,1:=1
      for i=2 to 9 {Append p, i:=i**i}
      Munchausen=lambda p (x)-> {
            m=0
            t=x
            do {
                  m+=p(x mod 10)
                  x=x div 10
            } until x=0
            =m=t
      }
      For i=1 to 5000
            If Munchausen(i) then print i,
      Next i
      Print
}
Munchausen


            NORMAL MODE IS INTEGER
            DIMENSION P(5)

            THROUGH CLCPOW, FOR D=0, 1, D.G.5
            P(D) = D
            THROUGH CLCPOW, FOR X=1, 1, X.GE.D
CLCPOW      P(D) = P(D) * D

            THROUGH TEST, FOR D1=0, 1, D1.G.5
            THROUGH TEST, FOR D2=0, 1, D2.G.5
            THROUGH TEST, FOR D3=0, 1, D3.G.5
            THROUGH TEST, FOR D4=1, 1, D4.G.5
            N = D1*1000 + D2*100 + D3*10 + D4
            WHENEVER P(D1)+P(D2)+P(D3)+P(D4) .E. N
                PRINT FORMAT FMT,N
TEST        END OF CONDITIONAL

            VECTOR VALUES FMT = $I4*$
            END OF PROGRAM


isMunchausen := proc(n::posint)
local num_digits;
num_digits := map(x -> StringTools:-Ord(x) - 48, StringTools:-Explode(convert(n, string)));
return evalb(n = convert(map(x -> x^x, num_digits), `+`));
end proc;

Munchausen_upto := proc(n::posint) local k, count, list_num;
list_num := [];
for k to n do
    if isMunchausen(k) then
       list_num := [op(list_num), k];
    end if;
end do;
return list_num;
end proc;

Munchausen_upto(5000);


Off[Power::indet];(*Supress 0^0 warnings*)
Select[Range[5000], Total[IntegerDigits[#]^IntegerDigits[#]] == # &]


(dup string "" split (int dup pow) (+) map-reduce ==) :munchausen?
1 :i
(i 5000 <=) ((i munchausen?) (i puts!) when i succ @i) while


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

(* Simple power function, does not handle negatives *)
PROCEDURE Pow(b,e : INTEGER) : INTEGER;
VAR result : INTEGER;
BEGIN
    IF e=0 THEN
        RETURN 1;
    END;
    IF b=0 THEN
        RETURN 0;
    END;

    result := b;
    DEC(e);
    WHILE e>0 DO
        result := result * b;
        DEC(e);
    END;
    RETURN result;
END Pow;

VAR
    buf : ARRAY[0..31] OF CHAR;
    i,sum,number,digit : INTEGER;
BEGIN
    FOR i:=1 TO 5000 DO
        (* Loop through each digit in i
           e.g. for 1000 we get 0, 0, 0, 1. *)
        sum := 0;
        number := i;
        WHILE number>0 DO
            digit := number MOD 10;
            sum := sum + Pow(digit, digit);
            number := number DIV 10;
        END;
        IF sum=i THEN
            FormatString("%i\n", buf, i);
            WriteString(buf);
        END;
    END;

    ReadChar;
END MunchausenNumbers.


import math

for i in 1..<5000:
  var sum: int64 = 0
  var number = i
  while number > 0:
    var digit = number mod 10
    sum += digit ^ digit
    number = number div 10
  if sum == i:
    echo i


{$IFDEF FPC}{$MODE objFPC}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}
uses
  sysutils;
type
  tdigit  = byte;
const
  base = 10;
  maxDigits = base-1;// set for 32-compilation otherwise overflow.

var
  DgtPotDgt : array[0..base-1] of NativeUint;
  cnt: NativeUint;

function CheckSameDigits(n1,n2:NativeUInt):boolean;
var
  dgtCnt : array[0..Base-1] of NativeInt;
  i : NativeUInt;
Begin
  fillchar(dgtCnt,SizeOf(dgtCnt),#0);
  repeat
    //increment digit of n1
    i := n1;n1 := n1 div base;i := i-n1*base;inc(dgtCnt[i]);
    //decrement digit of n2
    i := n2;n2 := n2 div base;i := i-n2*base;dec(dgtCnt[i]);
  until (n1=0) AND (n2= 0 );
  result := true;
  For i := 0 to Base-1 do
    result := result AND (dgtCnt[i]=0);
end;

procedure Munch(number,DgtPowSum,minDigit:NativeUInt;digits:NativeInt);
var
  i: NativeUint;
begin
  inc(cnt);
  number := number*base;
  IF digits > 1 then
  Begin
    For i := minDigit to base-1 do
      Munch(number+i,DgtPowSum+DgtPotDgt[i],i,digits-1);
  end
  else
    For i := minDigit to base-1 do
      //number is always the arrangement of the digits leading to smallest number
      IF (number+i)<= (DgtPowSum+DgtPotDgt[i]) then
        IF CheckSameDigits(number+i,DgtPowSum+DgtPotDgt[i]) then
          iF number+i>0 then
            writeln(Format('%*d  %.*d',
             [maxDigits,DgtPowSum+DgtPotDgt[i],maxDigits,number+i]));
end;

procedure InitDgtPotDgt;
var
  i,k,dgtpow: NativeUint;
Begin
  // digit ^ digit ,special case 0^0 here 0
  DgtPotDgt[0]:= 0;
  For i := 1 to Base-1 do
  Begin
    dgtpow := i;
    For k := 2 to i do
      dgtpow := dgtpow*i;
    DgtPotDgt[i] := dgtpow;
  end;
end;

begin
  cnt := 0;
  InitDgtPotDgt;
  Munch(0,0,0,maxDigits);
  writeln('Check Count ',cnt);
end.


use List::Util "sum";
for my $n (1..5000) {
  print "$n\n" if $n == sum( map { $_**$_ } split(//,$n) );
}


with javascript_semantics
constant powers = sq_power(tagset(9,0),tagset(9,0))

function munchausen(integer n)
    integer n0 = n
    atom total = 0
    while n!=0 do
        total += powers[remainder(n,10)+1]
        n = floor(n/10)
    end while
    return (total==n0)
end function

for i=1 to 5000 do
    if munchausen(i) then ?i end if
end for


<?php

$pwr = array_fill(0, 10, 0);

function isMunchhausen($n)
{
    global $pwr;
    $sm = 0;
    $temp = $n;
    while ($temp) {
        $sm= $sm + $pwr[($temp % 10)];
        $temp = (int)($temp / 10);
    }
    return $sm == $n;
}

for ($i = 0; $i < 10; $i++) {
    $pwr[$i] = pow((float)($i), (float)($i));
}

for ($i = 1; $i < 5000 + 1; $i++) {
    if (isMunchhausen($i)) {
        echo $i . PHP_EOL;
    }
}


go =>
  println([N : N in 1..5000, munchhausen_number(N)]).

munchhausen_number(N) =>
  N == sum([T : I in N.to_string(),II = I.to_int(), T = II**II]).


(for N 5000
   (and
      (=
         N
         (sum
            '((N) (** N N))
            (mapcar format (chop N)) ) )
      (println N) ) )


munchausen: procedure options(main);
    /* precalculate powers */
    declare (pows(0:5), i) fixed;
    pows(0) = 0; /* 0^0=0 for Munchausen numbers */
    do i=1 to 5; pows(i) = i**i; end;

    declare (d1, d2, d3, d4, num, dpow) fixed;
    do d1=0 to 5;
        do d2=0 to 5;
            do d3=0 to 5;
                do d4=1 to 5;
                    num = d1*1000 + d2*100 + d3*10 + d4;
                    dpow = pows(d1) + pows(d2) + pows(d3) + pows(d4);
                    if num=dpow then put skip list(num);
                end;
            end;
        end;
    end;
end munchausen;


To run:
Start up.
Show the Munchausen numbers up to 5000.
Wait for the escape key.
Shut down.

To show the Munchausen numbers up to a number:
If a counter is past the number, exit.
If the counter is Munchausen, convert the counter to a string; write the string to the console.
Repeat.

To decide if a number is Munchausen:
Privatize the number.
Find the sum of the digit self powers of the number.
If the number is the original number, say yes.
Say no.

To find the sum of the digit self powers of a number:
If the number is 0, exit.
Put 0 into a sum number.
Loop.
Divide the number by 10 giving a quotient and a remainder.
Put the quotient into the number.
Raise the remainder to the remainder.
Add the remainder to the sum.
If the number is 0, break.
Repeat.
Put the sum into the number.


#COMPILE EXE
#DIM ALL
#COMPILER PBCC 6

DECLARE FUNCTION GetTickCount LIB "kernel32.dll" ALIAS "GetTickCount"() AS DWORD

FUNCTION PBMAIN () AS LONG
LOCAL i, j, n, sum, ten1, ten2, t AS DWORD
LOCAL n0, n1, n2, n3, n4, n5, n6, n7, n8, n9 AS DWORD
LOCAL s1, s2, s3, s4, s5, s6, s7, s8 AS DWORD
DIM pow(9) AS DWORD, num(9) AS DWORD
LOCAL pb AS BYTE PTR
LOCAL number AS STRING

  t = GetTickCount()
  ten2 = 10
  FOR i = 1 TO 9
    pow(i) = i
    FOR j = 2 TO i
      pow(i) *= i
    NEXT j
  NEXT i
  FOR n = 1 TO 11
    FOR n9 = 0 TO n
      FOR n8 = 0 TO n - n9
        s8 = n9 + n8
        FOR n7 = 0 TO n - s8
          s7 = s8 + n7
          FOR n6 = 0 TO n - s7
            s6 = s7 + n6
            FOR n5 = 0 TO n - s6
              s5 = s6 + n5
              FOR n4 = 0 TO n - s5
                s4 = s5 + n4
                FOR n3 = 0 TO n - s4
                  s3 = s4 + n3
                  FOR n2 = 0 TO n - s3
                    s2 = s3 + n2
                    FOR n1 = 0 TO n - s2
                      n0 = n - (s2 + n1)
                      sum = n1 * pow(1) + n2 * pow(2) + n3 * pow(3) + _
                            n4 * pow(4) + n5 * pow(5) + n6 * pow(6) + _
                            n7 * pow(7) + n8 * pow(8) + n9 * pow(9)
                      SELECT CASE AS LONG sum
                      CASE ten1 TO ten2 - 1
                        number = LTRIM$(STR$(sum))
                        pb = STRPTR(number)
                        MAT num() = ZER
                        FOR i = 0 TO n -1
                          j = @pb[i] - 48
                          INCR num(j)
                        NEXT i
                        IF n0 = num(0) AND n1 = num(1) AND n2 = num(2) AND _
                           n3 = num(3) AND n4 = num(4) AND n5 = num(5) AND _
                           n6 = num(6) AND n7 = num(7) AND n8 = num(8) AND _
                           n9 = num(9) THEN CON.PRINT STR$(sum)
                      END SELECT
                    NEXT n1
                  NEXT n2
                NEXT n3
              NEXT n4
            NEXT n5
          NEXT n6
        NEXT n7
      NEXT n8
    NEXT n9
    ten1 = ten2
    ten2 *= 10
  NEXT n
  t = GetTickCount() - t
  CON.PRINT "execution time:" & STR$(t) & " ms; hit any key to end program"
  CON.WAITKEY$
END FUNCTION


// split numer into digits
digits n::number = loop n [] with
                     loop n l = loop (n div 10) ((n mod 10):l) if n > 0;
                              = l otherwise; end;

munchausen n::int = (filter isMunchausen list) when
                      list = 1..n; end with
                      isMunchausen n = n == foldl (+) 0
                                       (map (\d -> d^d)
                                        (digits n)); end;
munchausen 5000;


EnableExplicit
Declare main()

If OpenConsole("Munchausen_numbers")
  main() : Input() : End
EndIf

Procedure main()
  Define i.i,
         sum.i,
         number.i,
         digit.i
  For i = 1 To 5000
    sum = 0
    number = i
    While number > 0
      digit = number % 10
      sum + Pow(digit, digit)
      number / 10
    Wend
    If sum = i
      PrintN(Str(i))
    EndIf
  Next
EndProcedure


for i in range(5000):
    if i == sum(int(x) ** int(x) for x in str(i)):
        print(i)


 [ dup 0 swap
   [ dup 0 != while
     10 /mod dup **
     rot + swap again ]
    drop = ]             is munchausen ( n --> b )

  5000 times
    [ i^ 1+ munchausen if
      [ i^ 1+ echo sp ] ]


#lang racket

(define (expt:0^0=1 r p)
  (if (zero? r) 0 (expt r p)))

(define (munchausen-number? n (t n))
  (if (zero? n)
      (zero? t)
      (let-values (([q r] (quotient/remainder n 10)))
        (munchausen-number? q (- t (expt:0^0=1 r r))))))

(module+ main
  (for-each displayln (filter munchausen-number? (range 1 (add1 5000)))))

(module+ test
  (require rackunit)
  ;; this is why we have the (if (zero? r)...) test
  (check-equal? (expt 0 0) 1)
  (check-equal? (expt:0^0=1 0 0) 0)
  (check-equal? (expt:0^0=1 0 4) 0)
  (check-equal? (expt:0^0=1 3 4) (expt 3 4))
  ;; given examples
  (check-true (munchausen-number? 1))
  (check-true (munchausen-number? 3435))
  (check-false (munchausen-number? 3))
  (check-false (munchausen-number? -45) "no recursion on -ve numbers"))


sub is_munchausen ( Int $n ) {
    constant @powers = 0, |map { $_ ** $_ }, 1..9;
    $n == @powers[$n.comb].sum;
}
.say if .&is_munchausen for 1..5000;


Do n=0 To 10000
  If n=m(n) Then
    Say n
  End
Exit
m: Parse Arg z
res=0
Do While z>''
  Parse Var z c +1 z
  res=res+c**c
  End
Return res


# Project : Munchausen numbers

limit = 5000

for n=1 to limit
    sum = 0
    msum = string(n)
    for m=1 to len(msum)
        ms = number(msum[m])
        sum = sum + pow(ms, ms)
    next
    if sum = n
       see n + nl
    ok
next


class Integer

  def munchausen?
    self.digits.map{|d| d**d}.sum == self
  end

end

puts (1..5000).select(&:munchausen?)


fn main() {
    let mut solutions = Vec::new();

    for num in 1..5_000 {
        let power_sum = num.to_string()
            .chars()
            .map(|c| {
                let digit = c.to_digit(10).unwrap();
                (digit as f64).powi(digit as i32) as usize
            })
            .sum::<usize>();

        if power_sum == num {
            solutions.push(num);
        }
    }

    println!("Munchausen numbers below 5_000 : {:?}", solutions);
}


object Munch {
  def main(args: Array[String]): Unit = {
    import scala.math.pow
    (1 to 5000).foreach {
      i => if (i == (i.toString.toCharArray.map(d => pow(d.asDigit,d.asDigit))).sum)
        println( i + " (munchausen)")
    }
  }
}


func is_munchausen(n) {
    n.digits.map{|d| d**d }.sum == n
}

say (1..5000 -> grep(is_munchausen))


(1..5000).select { |n| n == n.asDigits.sum { |x| pow(x, x) } }


import Foundation

func isMünchhausen(_ n: Int) -> Bool {
  let nums = String(n).map(String.init).compactMap(Int.init)

  return Int(nums.map({ pow(Double($0), Double($0)) }).reduce(0, +)) == n
}

for i in 1...5000 where isMünchhausen(i) {
  print(i)
}


x : 10 1

 (2^2) x.2
 (3^3) x.3
 (4^4) x.4
 (5^5) x.5
 (6^6) x.6
 (7^7) x.7
 (8^8) x.8
 (9^9) x.9

 1 i
 if i <= 5000
    ~ i $i          | convert binary to string
    #$i j           | length to j
    y               | set y to 0
    if j > 0
       $i.j $j 1    | move digit j to string j
       ~ $j n       | convert j string to binary
       + x.n y      | add value x at n to y
       - j          | dec j
       goif
    endif
    if i = y
       i []         | output to console
    endif
    + i
    goif
 endif


  For(I,1,5000)
    0→S:I→K
    For(J,1,4)
      10^(4-J)→D
      iPart(K/D)→N
      remainder(K,D)→R
      If N≠0:S+N^N→S
      R→K
    End
    If S=I:Disp I
  End


Option Explicit

Sub Main_Munchausen_numbers()
Dim i&

    For i = 1 To 5000
        If IsMunchausen(i) Then Debug.Print i & " is a munchausen number."
    Next i
End Sub

Function IsMunchausen(Number As Long) As Boolean
Dim Digits, i As Byte, Tot As Long

    Digits = Split(StrConv(Number, vbUnicode), Chr(0))
    For i = 0 To UBound(Digits) - 1
        Tot = (Digits(i) ^ Digits(i)) + Tot
    Next i
    IsMunchausen = (Tot = Number)
End Function


for i = 1 to 5000
    if Munch(i) Then
        Wscript.Echo i, "is a Munchausen number"
    end if
next

'Returns True if num is a Munchausen number. This is true if the sum of
'each digit raised to that digit's power is equal to the given number.
'Example: 3435 = 3^3 + 4^4 + 3^3 + 5^5

Function Munch (num)

    dim str: str = Cstr(num)    'input num as a string
    dim sum: sum = 0            'running sum of n^n
    dim i                       'loop index
    dim n                       'extracted digit

    for i = 1 to len(str)
        n = CInt(Mid(str,i,1))
        sum = sum + n^n
    next

    Munch = (sum = num)

End Function


Option Explicit

Declare Function GetTickCount Lib "kernel32.dll" () As Long
Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByRef Destination As Any, ByVal Length As Long)

Sub Main()
Dim i As Long, j As Long, n As Long, t As Long
Dim sum As Double
Dim n0 As Double
Dim n1 As Double
Dim n2 As Double
Dim n3 As Double
Dim n4 As Double
Dim n5 As Double
Dim n6 As Double
Dim n7 As Double
Dim n8 As Double
Dim n9 As Double
Dim ten1 As Double
Dim ten2 As Double
Dim s1 As Long
Dim s2 As Long
Dim s3 As Long
Dim s4 As Long
Dim s5 As Long
Dim s6 As Long
Dim s7 As Long
Dim s8 As Long
Dim pow(9) As Long, num(9) As Long
Dim number As String, res As String

  t = GetTickCount()
  ten2 = 10
  For i = 1 To 9
    pow(i) = i
    For j = 2 To i
      pow(i) = i * pow(i)
    Next j
  Next i
  For n = 1 To 11
    For n9 = 0 To n
      For n8 = 0 To n - n9
        s8 = n9 + n8
        For n7 = 0 To n - s8
          s7 = s8 + n7
          For n6 = 0 To n - s7
            s6 = s7 + n6
            For n5 = 0 To n - s6
              s5 = s6 + n5
              For n4 = 0 To n - s5
                s4 = s5 + n4
                For n3 = 0 To n - s4
                  s3 = s4 + n3
                  For n2 = 0 To n - s3
                    s2 = s3 + n2
                    For n1 = 0 To n - s2
                      n0 = n - (s2 + n1)
                      sum = n1 * pow(1) + n2 * pow(2) + n3 * pow(3) + _
                            n4 * pow(4) + n5 * pow(5) + n6 * pow(6) + _
                            n7 * pow(7) + n8 * pow(8) + n9 * pow(9)
                      Select Case sum
                      Case ten1 To ten2 - 1
                        number = CStr(sum)
                        ZeroMemory num(0), 40
                        For i = 1 To n
                          j = Asc(Mid$(number, i, 1)) - 48
                          num(j) = num(j) + 1
                        Next i
                        If n0 = num(0) Then
                          If n1 = num(1) Then
                            If n2 = num(2) Then
                              If n3 = num(3) Then
                                If n4 = num(4) Then
                                  If n5 = num(5) Then
                                    If n6 = num(6) Then
                                      If n7 = num(7) Then
                                        If n8 = num(8) Then
                                          If n9 = num(9) Then
                                            res = res & CStr(sum) & vbNewLine
                                          End If
                                        End If
                                      End If
                                    End If
                                  End If
                                End If
                              End If
                            End If
                          End If
                        End If
                      End Select
                    Next n1
                  Next n2
                Next n3
              Next n4
            Next n5
          Next n6
        Next n7
      Next n8
    Next n9
    ten1 = ten2
    ten2 = ten2 * 10
  Next n
  t = GetTickCount() - t
  res = res & "execution time:" & Str$(t) & " ms"
  MsgBox res
End Sub


Imports System

Module Program
    Sub Main()
        Dim i, j, n, n1, n2, n3, n4, n5, n6, n7, n8, n9, s2, s3, s4, s5, s6, s7, s8 As Integer,
            sum, ten1 As Long, ten2 As Long = 10
        Dim pow(9) As Long, num() As Byte
        For i = 1 To 9 : pow(i) = i : For j = 2 To i : pow(i) *= i : Next : Next
        For n = 1 To 11 : For n9 = 0 To n : For n8 = 0 To n - n9 : s8 = n9 + n8 : For n7 = 0 To n - s8
                s7 = s8 + n7 : For n6 = 0 To n - s7 : s6 = s7 + n6 : For n5 = 0 To n - s6
                    s5 = s6 + n5 : For n4 = 0 To n - s5 : s4 = s5 + n4 : For n3 = 0 To n - s4
                        s3 = s4 + n3 : For n2 = 0 To n - s3 : s2 = s3 + n2 : For n1 = 0 To n - s2
                            sum = n1 * pow(1) + n2 * pow(2) + n3 * pow(3) + n4 * pow(4) +
                                  n5 * pow(5) + n6 * pow(6) + n7 * pow(7) + n8 * pow(8) + n9 * pow(9)
                            If sum < ten1 OrElse sum >= ten2 Then Continue For
                            redim num(9)
                            For Each ch As Char In sum.ToString() : num(Convert.ToByte(ch) - 48) += 1 : Next
                            If n - (s2 + n1) = num(0) AndAlso n1 = num(1) AndAlso n2 = num(2) AndAlso
                                n3 = num(3) AndAlso n4 = num(4) AndAlso n5 = num(5) AndAlso n6 = num(6) AndAlso
                                n7 = num(7) AndAlso n8 = num(8) AndAlso n9 = num(9) Then Console.WriteLine(sum)
                          Next : Next : Next : Next : Next : Next : Next : Next : Next
            ten1 = ten2 : ten2 *= 10
       Next
    End Sub
End Module


var powers = List.filled(10, 0)
for (i in 1..9) powers[i] = i.pow(i).round // cache powers

var munchausen = Fn.new {|n|
    if (n <= 0) Fiber.abort("Argument must be a positive integer.")
    var nn = n
    var sum = 0
    while (n > 0) {
        var digit = n % 10
        sum = sum + powers[digit]
        n = (n/10).floor
    }
    return nn == sum
}

System.print(powers)
System.print("The Munchausen numbers <= 5000 are:")
for (i in 1..5000) {
    if (munchausen.call(i)) System.print(i)
}


[1..5000].filter(fcn(n){ n==n.split().reduce(fcn(s,n){ s + n.pow(n) },0) })
.println();


F multisplit(text, sep)
   V lastmatch = 0
   V i = 0
   V matches = ‘’
   L i < text.len
      L(s) sep
         V j = L.index
         I text[i..].starts_with(s)
            I i > lastmatch
               matches ‘’= text[lastmatch .< i]
            matches ‘’= ‘{’s‘}’
            lastmatch = i + s.len
            i += s.len
            L.break
      L.was_no_break
         i++
   I i > lastmatch
      matches ‘’= text[lastmatch .< i]
   R matches

print(multisplit(‘a!===b=!=c’, [‘==’, ‘!=’, ‘=’]))


with Ada.Containers.Indefinite_Doubly_Linked_Lists;
with Ada.Text_IO;

procedure Multisplit is
   package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
     (Element_Type => String);
   use type String_Lists.Cursor;

   function Split
     (Source     : String;
      Separators : String_Lists.List)
      return       String_Lists.List
   is
      Result             : String_Lists.List;
      Next_Position      : Natural := Source'First;
      Prev_Position      : Natural := Source'First;
      Separator_Position : String_Lists.Cursor;
      Separator_Length   : Natural;
      Changed            : Boolean;
   begin
      loop
         Changed            := False;
         Separator_Position := Separators.First;
         while Separator_Position /= String_Lists.No_Element loop
            Separator_Length :=
              String_Lists.Element (Separator_Position)'Length;
            if Next_Position + Separator_Length - 1 <= Source'Last
              and then Source
                (Next_Position .. Next_Position + Separator_Length - 1) =
                String_Lists.Element (Separator_Position)
            then
               if Next_Position > Prev_Position then
                  Result.Append
                    (Source (Prev_Position .. Next_Position - 1));
               end if;
               Result.Append (String_Lists.Element (Separator_Position));
               Next_Position := Next_Position + Separator_Length;
               Prev_Position := Next_Position;
               Changed       := True;
               exit;
            end if;
            Separator_Position := String_Lists.Next (Separator_Position);
         end loop;
         if not Changed then
            Next_Position := Next_Position + 1;
         end if;
         if Next_Position > Source'Last then
            Result.Append (Source (Prev_Position .. Source'Last));
            exit;
         end if;
      end loop;
      return Result;
   end Split;

   Test_Input      : constant String := "a!===b=!=c";
   Test_Separators : String_Lists.List;
   Test_Result     : String_Lists.List;
   Pos             : String_Lists.Cursor;
begin
   Test_Separators.Append ("==");
   Test_Separators.Append ("!=");
   Test_Separators.Append ("=");
   Test_Result := Split (Test_Input, Test_Separators);
   Pos         := Test_Result.First;
   while Pos /= String_Lists.No_Element loop
      Ada.Text_IO.Put (" " & String_Lists.Element (Pos));
      Pos := String_Lists.Next (Pos);
   end loop;
   Ada.Text_IO.New_Line;
   -- other order of separators
   Test_Separators.Clear;
   Test_Separators.Append ("=");
   Test_Separators.Append ("!=");
   Test_Separators.Append ("==");
   Test_Result := Split (Test_Input, Test_Separators);
   Pos         := Test_Result.First;
   while Pos /= String_Lists.No_Element loop
      Ada.Text_IO.Put (" " & String_Lists.Element (Pos));
      Pos := String_Lists.Next (Pos);
   end loop;
end Multisplit;


# split a string based on a number of separators #

# MODE to hold the split results #
MODE SPLITINFO = STRUCT( STRING text      # delimited string, may be empty          #
                       , INT    position  # starting position of the token          #
                       , STRING delimiter # the delimiter that terminated the token #
                       );
# calculates the length of string s #
OP   LENGTH = ( STRING s )INT: ( UPB s + 1 ) - LWB s;
# returns TRUE if s starts with p, FALSE otherwise #
PRIO STARTSWITH = 5;
OP   STARTSWITH = ( STRING s, p )BOOL: IF LENGTH p > LENGTH s THEN FALSE ELSE s[ LWB s : ( LWB s + LENGTH p ) - 1 ] = p FI;
# returns an array of SPLITINFO describing the tokens in str based on the delimiters #
# zero-length delimiters are ignored #
PRIO SPLIT = 5;
OP   SPLIT = ( STRING str, []STRING delimiters )[]SPLITINFO:
     BEGIN
        # count the number of tokens #
        # allow there to be as many tokens as characters in the string + 2 #
        # that would cater for a string composed of delimiters only        #
        [ 1 : ( UPB str + 3 ) - LWB str ]SPLITINFO tokens;
        INT   token count   := 0;
        INT   str pos       := LWB str;
        INT   str max        = UPB str;
        BOOL  token pending := FALSE;
        # construct the tokens #
        str pos       := LWB str;
        INT prev pos  := LWB str;
        token count   := 0;
        token pending := FALSE;
        WHILE str pos <= str max
        DO
            BOOL found delimiter := FALSE;
            FOR d FROM LWB delimiters TO UPB delimiters WHILE NOT found delimiter DO
                IF LENGTH delimiters[ d ] > 0 THEN
                    IF found delimiter := str[ str pos : ] STARTSWITH delimiters[ d ] THEN
                        token count          +:= 1;
                        tokens[ token count ] := ( str[ prev pos : str pos - 1 ], prev pos, delimiters[ d ] );
                        str pos              +:= LENGTH delimiters[ d ];
                        prev pos              := str pos;
                        token pending         := FALSE
                    FI
                FI
            OD;
            IF NOT found delimiter THEN
                # the current character is part of s token #
                token pending := TRUE;
                str pos      +:= 1
            FI
        OD;
        IF token pending THEN
            # there is an additional token after the final delimiter #
            token count +:= 1;
            tokens[ token count ] := ( str[ prev pos : ], prev pos, "" )
        FI;
        # return an array of the actual tokens #
        tokens[ 1 : token count ]
     END # SPLIT # ;

# test the SPLIT operator #
[]SPLITINFO test tokens = "a!===b=!=c" SPLIT []STRING( "==", "!=", "=" );
FOR t FROM LWB test tokens TO UPB test tokens DO
    SPLITINFO token = test tokens[ t ];
    print( ( "token: [",  text OF token, "] at: ", whole( position OF token, 0 ), " delimiter: (", delimiter OF token, ")", newline ) )
OD


Str := "a!===b=!=c"
Sep := ["==","!=", "="]
Res := StrSplit(Str, Sep)
for k, v in Res
	Out .= (Out?",":"")  v
MsgBox % Out
for k, v in Sep
	N .= (N?"|":"") "\Q" v "\E"
MsgBox % RegExReplace(str, "(.*?)(" N ")", "$1 {$2}")


# syntax: GAWK -f MULTISPLIT.AWK
BEGIN {
    str = "a!===b=!=c"
    sep = "(==|!=|=)"
    printf("str: %s\n",str)
    printf("sep: %s\n\n",sep)
    n = split(str,str_arr,sep,sep_arr)
    printf("parsed: ")
    for (i=1; i<=n; i++) {
      printf("'%s'",str_arr[i])
      if (i<n) { printf(" '%s' ",sep_arr[i]) }
    }
    printf("\n\nstrings: ")
    for (i=1; i<=n; i++) {
      printf("'%s' ",str_arr[i])
    }
    printf("\n\nseparators: ")
    for (i=1; i<n; i++) {
      printf("'%s' ",sep_arr[i])
    }
    printf("\n")
    exit(0)
}


      DIM sep$(2)
      sep$() = "==", "!=", "="
      PRINT "String splits into:"
      PRINT FNmultisplit("a!===b=!=c", sep$(), FALSE)
      PRINT "For extra credit:"
      PRINT FNmultisplit("a!===b=!=c", sep$(), TRUE)
      END

      DEF FNmultisplit(s$, d$(), info%)
      LOCAL d%, i%, j%, m%, p%, o$
      p% = 1
      REPEAT
        m% = LEN(s$)
        FOR i% = 0 TO DIM(d$(),1)
          d% = INSTR(s$, d$(i%), p%)
          IF d% IF d% < m% m% = d% : j% = i%
        NEXT
        IF m% < LEN(s$) THEN
          o$ += """" + MID$(s$, p%, m%-p%) + """"
          IF info% o$ += " (" + d$(j%) + ") " ELSE o$ += ", "
          p% = m% + LEN(d$(j%))
        ENDIF
      UNTIL m% = LEN(s$)
      = o$ + """" + MID$(s$, p%) + """"


( ( oneOf
  =   operator
    .   !arg:%?operator ?arg
      & ( @(!sjt:!operator ?arg)&(!operator.!arg)
        | oneOf$!arg
        )
  )
& "a!===b=!=c":?unparsed
& "==" "!=" "=":?operators
&   whl
  ' ( @( !unparsed
       : ?nonOp [%(oneOf$!operators:(?operator.?unparsed))
       )
    & put$(!nonOp str$("{" !operator "} "))
    )
& put$!unparsed
& put$\n
);


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

void parse_sep(const char *str, const char *const *pat, int len)
{
	int i, slen;
	while (*str != '\0') {
		for (i = 0; i < len || !putchar(*(str++)); i++) {
			slen = strlen(pat[i]);
			if (strncmp(str, pat[i], slen)) continue;
			printf("{%.*s}", slen, str);
			str += slen;
			break;
		}
	}
}

int main()
{
	const char *seps[] = { "==", "!=", "=" };
	parse_sep("a!===b=!=c", seps, 3);

	return 0;
}


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

namespace Multisplit
{
    internal static class Program
    {
        private static void Main(string[] args)
        {
            foreach (var s in "a!===b=!=c".Multisplit(true, "==", "!=", "=")) // Split the string and return the separators.
            {
                Console.Write(s); // Write the returned substrings and separators to the console.
            }
            Console.WriteLine();
        }

        private static IEnumerable<string> Multisplit(this string s, bool returnSeparators = false,
                                                      params string[] delimiters)
        {
            var currentString = new StringBuilder(); /* Initiate the StringBuilder. This will hold the current string to return
                                                      * once we find a separator. */

            int index = 0; // Initiate the index counter at 0. This tells us our current position in the string to read.

            while (index < s.Length) // Loop through the string.
            {
                // This will get the highest priority separator found at the current index, or null if there are none.
                string foundDelimiter =
                    (from delimiter in delimiters
                     where s.Length >= index + delimiter.Length &&
                           s.Substring(index, delimiter.Length) == delimiter
                     select delimiter).FirstOrDefault();

                if (foundDelimiter != null)
                {
                    yield return currentString.ToString(); // Return the current string.
                    if (returnSeparators) // Return the separator, if the user specified to do so.
                        yield return
                            string.Format("{{\"{0}\", ({1}, {2})}}",
                                          foundDelimiter,
                                          index, index + foundDelimiter.Length);
                    currentString.Clear(); // Clear the current string.
                    index += foundDelimiter.Length; // Move the index past the current separator.
                }
                else
                {
                    currentString.Append(s[index++]); // Add the character at this index to the current string.
                }
            }

            if (currentString.Length > 0)
                yield return currentString.ToString(); // If we have anything left over, return it.
        }
    }
}


#include <iostream>
#include <boost/tokenizer.hpp>
#include <string>

int main( ) {
   std::string str( "a!===b=!=c" ) , output ;
   typedef boost::tokenizer<boost::char_separator<char> > tokenizer ;
   boost::char_separator<char> separator ( "==" , "!=" ) , sep ( "!" )  ;
   tokenizer mytok( str , separator ) ;
   tokenizer::iterator tok_iter = mytok.begin( ) ;
   for ( ; tok_iter != mytok.end( ) ; ++tok_iter )
      output.append( *tok_iter ) ;
   tokenizer nexttok ( output , sep ) ;
   for ( tok_iter = nexttok.begin( ) ; tok_iter != nexttok.end( ) ;
	 ++tok_iter )
      std::cout << *tok_iter << " " ;
   std::cout << '\n' ;
   return 0 ;
}


multi_split = (text, separators) ->
  # Split text up, using separators to break up text and discarding
  # separators.
  #
  # Returns an array of strings, which can include empty strings when
  # separators are found either adjacent to each other or at the
  # beginning/end of the text.
  #
  # Separators have precedence, according to their order in the array,
  # and each separator should be at least one character long.
  result = []
  i = 0
  s = ''
  while i < text.length
    found = false
    for separator in separators
      if text.substring(i, i + separator.length) == separator
        found = true
        i += separator.length
        result.push s
        s = ''
        break
    if !found
      s += text[i]
      i += 1
  result.push s
  result

console.log multi_split 'a!===b=!=c', ['==', '!=', '='] # [ 'a', '', 'b', '', 'c' ]
console.log multi_split '', ['whatever'] # [ '' ]


import std.stdio, std.array, std.algorithm;

string[] multiSplit(in string s, in string[] divisors) pure nothrow {
    string[] result;
    auto rest = s.idup;

    while (true) {
	    bool done = true;
        string delim;
        {
            string best;
            foreach (const div; divisors) {
                const maybe = rest.find(div);
                if (maybe.length > best.length) {
                    best = maybe;
                    delim = div;
                    done = false;
                }
            }
        }
	    result.length++;
	    if (done) {
            result.back = rest.idup;
		    return result;
	    } else {
            const t = rest.findSplit(delim);
		    result.back = t[0].idup;
		    rest = t[2];
	    }
    }
}

void main() {
    "a!===b=!=c"
    .multiSplit(["==", "!=", "="])
    .join(" {} ")
    .writeln;
}


program Multisplit;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

begin
  write('[');
  for var s in 'a!===b=!=c'.Split(['==', '!=', '=']) do
    write(s.QuotedString('"'), ' ');
  write(']');
  readln;
end.


USING: arrays fry kernel make sequences ;

IN: rosetta-code.multisplit

: ?pair ( ? x -- {?,x}/f )
    over [ 2array ] [ 2drop f ] if ;

: best-separator ( seq -- pos index )
    dup [ first ] map infimum '[ first _ = ] find nip first2 ;

: first-subseq ( separators seq -- n separator )
    dupd [ swap [ subseq-start ] dip ?pair ] curry map-index sift
    [ drop f f ] [ best-separator rot nth ] if-empty ;

: multisplit ( string separators -- seq )
    '[
        [ _ over first-subseq dup ] [
            length -rot cut-slice swap , swap tail-slice
        ] while 2drop ,
    ] { } make ;


' FB 1.05.0 Win64

Sub Split(s As String, sepList() As String, result() As String, removeEmpty As Boolean = False, showSepInfo As Boolean = False)
  If s = "" OrElse UBound(sepList) = -1 Then
     Redim result(0)
     result(0) = s
     Return
  End If
  Dim As Integer i = 0, j, count = 0, empty = 0, length
  Dim As Integer position(len(s) + 1)
  Dim As Integer sepIndex(1 To len(s))
  Dim As Integer sepLength(len(s))
  position(0) = 0 : sepLength(0) = 1

  While i  < Len(s)
    For j = lbound(sepList) To ubound(sepList)
      length = len(sepList(j))
      If length = 0 Then Continue For '' ignore blank separators
      If mid(s, i + 1, length) = sepList(j) Then
        count += 1
        position(count) = i + 1
        sepIndex(count) = j
        sepLength(count) = length
        i += length - 1
        Exit For
      End If
    Next j
    i += 1
  Wend

  Redim result(count)
  If count  = 0 Then
    If showSepInfo Then
      Print "No delimiters were found" : Print
    End If
    result(0) = s
    Return
  End If
  position(count + 1) = len(s) + 1

  For i = 1 To count + 1
    length = position(i) - position(i - 1) - sepLength(i - 1)
    result(i - 1 - empty) = Mid(s, position(i - 1) + sepLength(i - 1), length)
    If removeEmpty AndAlso cbool(length = 0) Then empty += 1
  Next

  If empty > 0 Then Redim Preserve result(count - empty)

  If showSepInfo Then
    Print "The 1-based indices of the delimiters found are : "
    Print
    For x As Integer = 1 To count
      Print "At index"; position(x), sepList(sepIndex(x))
    Next
    Print
  End If
End Sub

Dim s As String = "a!===b=!=c"
Print "The string to be split is : "; s
Print
Dim a() As String '' to hold results
Dim b(1 To 3) As String = {"==", "!=", "="} '' separators to be used in order of priority (highest first)
split s, b(), a(), False, True  '' show separator info
Print "The sub-strings are : "
Print
For i As integer = 0 To ubound(a)
 Print Using "##"; i + 1;
 Print " : "; a(i)
Next
Print
Print "Press any key to quit"
Sleep


package main

import (
    "fmt"
    "strings"
)

func ms(txt string, sep []string) (ans []string) {
    for txt > "" {
        sepMatch := ""
        posMatch := len(txt)
        for _, s := range sep {
            if p := strings.Index(txt, s); p >= 0 && p < posMatch {
                sepMatch = s
                posMatch = p
            }
        }
        ans = append(ans, txt[:posMatch])
        txt = txt[posMatch+len(sepMatch):]
    }
    return
}

func main() {
    fmt.Printf("%q\n", ms("a!===b=!=c", []string{"==", "!=", "="}))
}


import Data.List
       (isPrefixOf, stripPrefix, genericLength, intercalate)

trysplit :: String -> [String] -> Maybe (String, String)
trysplit s delims =
  case filter (`isPrefixOf` s) delims of
    [] -> Nothing
    (d:_) -> Just (d, (\(Just x) -> x) $ stripPrefix d s)

multisplit :: String -> [String] -> [(String, String, Int)]
multisplit list delims =
  let ms [] acc pos = [(acc, [], pos)]
      ms l@(s:sx) acc pos =
        case trysplit l delims of
          Nothing -> ms sx (s : acc) (pos + 1)
          Just (d, sxx) -> (acc, d, pos) : ms sxx [] (pos + genericLength d)
  in ms list [] 0

main :: IO ()
main = do
  let parsed = multisplit "a!===b=!=c" ["==", "!=", "="]
  mapM_
    putStrLn
    [ "split string:"
    , intercalate "," $ map (\(a, _, _) -> a) parsed
    , "with [(string, delimiter, offset)]:"
    , show parsed
    ]


procedure main()
   s := "a!===b=!=c"
   # just list the tokens
   every writes(multisplit(s,["==", "!=", "="])," ") | write()

   # list tokens and indices
   every ((p := "") ||:= t := multisplit(s,sep := ["==", "!=", "="])) | break write() do
      if t == !sep then writes(t," (",*p+1-*t,") ") else writes(t," ")

end

procedure multisplit(s,L)
s ? while not pos(0) do {
   t := =!L | 1( arb(), match(!L)|pos(0) )
   suspend t
   }
end

procedure arb()
suspend .&subject[.&pos:&pos <- &pos to *&subject + 1]
end


multisplit=: 4 :0
  'sep begin'=. |: t=. y /:~&.:(|."1)@;@([email protected]#@[ ,.L:0"0 [email protected]:0) x
  end=. begin + sep { #@>y
  last=. next=. 0
  r=. 2 0$0
  while. next<#begin do.
    r=. r,.(last}.x{.~next{begin);next{t
    last=. next{end
    next=. 1 i.~(begin>next{begin)*.begin>:last
  end.
  r=. r,.'';~last}.x
)


import java.util.*;

public class MultiSplit {

    public static void main(String[] args) {
        System.out.println("Regex split:");
        System.out.println(Arrays.toString("a!===b=!=c".split("==|!=|=")));

        System.out.println("\nManual split:");
        for (String s : multiSplit("a!===b=!=c", new String[]{"==", "!=", "="}))
            System.out.printf("\"%s\" ", s);
    }

    static List<String> multiSplit(String txt, String[] separators) {
        List<String> result = new ArrayList<>();
        int txtLen = txt.length(), from = 0;

        for (int to = 0; to < txtLen; to++) {
            for (String sep : separators) {
                int sepLen = sep.length();
                if (txt.regionMatches(to, sep, 0, sepLen)) {
                    result.add(txt.substring(from, to));
                    from = to + sepLen;
                    to = from - 1; // compensate for the increment
                    break;
                }
            }
        }
        if (from < txtLen)
            result.add(txt.substring(from));
        return result;
    }
}


RegExp.escape = function(text) {
    return text.replace(/[-[\]{}()*+?.,\\^$|#\s]/g, "\\$&");
}

multisplit = function(string, seps) {
    var sep_regex = RegExp(_.map(seps, function(sep) { return RegExp.escape(sep); }).join('|'));
    return string.split(sep_regex);
}


# peeloff(delims) either peels off a delimiter or
# a single character from the input string.
# The input should be a nonempty string, and delims should be
# a non-empty array of delimiters;
# return [peeledoff, remainder]
# where "peeledoff" is either [delim] or the peeled off character:
def peeloff(delims):
  delims[0] as $delim
  | if startswith($delim) then [ [$delim], .[ ($delim|length):]]
    elif (delims|length)>1 then peeloff(delims[1:])
    else [ .[0:1], .[1:]]
    end ;

# multisplit_parse(delims) produces an intermediate parse.
# Input must be of the parse form: [ string, [ delim ], ... ]
# Output is of the same form.
def multisplit_parse(delims):
  if (delims|length) == 0 or length == 0 then .
  else
    .[length-1] as $last
    |  .[0:length-1] as $butlast
    | if ($last|type) == "array" then . # all done
      elif $last == "" then .
      else
        ($last | peeloff(delims)) as $p # [ peeledoff, next ]
        | $p[0] as $peeledoff
        | $p[1] as $next
        | if ($next|length) > 0
          then $butlast + [$peeledoff] + ([$next]|multisplit_parse(delims))
          else $butlast + $p
          end
      end
  end ;

def multisplit(delims):
  [.] | multisplit_parse(delims)
  # insert "" between delimiters, compress strings, remove trailing "" if any
  | reduce .[] as $x ([];
      if length == 0 then [ $x ]
      elif ($x|type) == "array"
      then if (.[length-1]|type) == "array" then . + ["",  $x]
           else  . + [$x]
           end
      elif .[length-1]|type == "string"
      then .[0:length-1] + [ .[length-1] + $x ]
      else  . + [$x]
      end ) ;


julia> split(s, r"==|!=|=")
 5-element Array{SubString{String},1}:
  "a"
  ""
  "b"
  ""
  "c"


// version 1.0.6

fun main(args: Array<String>) {
    val input = "a!===b=!=c"
    val delimiters = arrayOf("==", "!=", "=")
    val output = input.split(*delimiters).toMutableList()
    for (i in 0 until output.size) {
        if (output[i].isEmpty()) output[i] = "empty string"
        else output[i] = "\"" + output[i] + "\""
    }
    println("The splits are:")
    println(output)

    // now find positions of matched delimiters
    val matches = mutableListOf<Pair<String, Int>>()
    var index = 0
    while (index < input.length) {
        var matched = false
        for (d in delimiters) {
            if (input.drop(index).take(d.length) == d) {
                matches.add(d to index)
                index += d.length
                matched = true
                break
            }
        }
        if (!matched) index++
    }
    println("\nThe delimiters matched and the indices at which they occur are:")
    println(matches)
}


--[[
Returns a table of substrings by splitting the given string on
occurrences of the given character delimiters, which may be specified
as a single- or multi-character string or a table of such strings.
If chars is omitted, it defaults to the set of all space characters,
and keep is taken to be false. The limit and keep arguments are
optional: they are a maximum size for the result and a flag
determining whether empty fields should be kept in the result.
]]
function split (str, chars, limit, keep)
    local limit, splitTable, entry, pos, match = limit or 0, {}, "", 1
    if keep == nil then keep = true end
    if not chars then
        for e in string.gmatch(str, "%S+") do
                table.insert(splitTable, e)
        end
        return splitTable
    end
    while pos <= str:len() do
        match = nil
        if type(chars) == "table" then
            for _, delim in pairs(chars) do
                if str:sub(pos, pos + delim:len() - 1) == delim then
                    match = string.len(delim) - 1
                    break
                end
            end
        elseif str:sub(pos, pos + chars:len() - 1) == chars then
            match = string.len(chars) - 1
        end
        if match then
            if not (keep == false and entry == "") then
                table.insert(splitTable, entry)
                if #splitTable == limit then return splitTable end
                entry = ""
            end
        else
            entry = entry .. str:sub(pos, pos)
        end
        pos = pos + 1 + (match or 0)
    end
    if entry ~= "" then table.insert(splitTable, entry) end
    return splitTable
end

local multisplit = split("a!===b=!=c", {"==", "!=", "="})

-- Returned result is a table (key/value pairs) - display all entries
print("Key\tValue")
print("---\t-----")
for k, v in pairs(multisplit) do
    print(k, v)
end


Module CheckIt {
            DIM sep$()
            sep$() = ("==", "!=", "=")
            PRINT "String splits into:"
            FNmultisplit("a!===b=!=c", sep$(), FALSE)
            PRINT "For extra credit:"
            FNmultisplit("a!===b=!=c", sep$(), TRUE)
            END

            SUB FNmultisplit(s$, d$(), info%)
            LOCAL d%, i%, j%, m%, p%, o$
            p% = 1
            REPEAT {
                    m% = LEN(s$)
                    FOR i% = 0 TO DIMENSION(d$(),1)-1
                      d% = INSTR(s$, d$(i%), p%)
                      IF d% THEN IF d% < m% THEN m% = d% : j% = i%
                    NEXT I%
                    IF m% < LEN(s$) THEN {
                            o$ += """" + MID$(s$, p%, m%-p%) + """"
                            IF info% THEN  {o$ += " (" + d$(j%) + ") "} ELSE o$ += ", "
                            p% = m% + LEN(d$(j%))
                  }

            } UNTIL m% = LEN(s$)
            PRINT  o$ + """" + MID$(s$, p%) + """"
            END SUB
}
CheckIt


parseSep = function(s, pats)
    result = []
    startPos = 0
    pos = 0
    while pos < s.len
        for pat in pats
            if s[pos : pos+pat.len] != pat then continue
            result.push s[startPos : pos]
            result.push "{" + pat + "}"
            startPos = pos + pat.len
            pos = startPos - 1
            break
        end for
        pos = pos + 1
    end while
    return result
end function

print parseSep("a!===b=!=c", ["==", "!=", "="])


import strutils

iterator tokenize(text: string; sep: openArray[string]): tuple[token: string, isSep: bool] =
  var i, lastMatch = 0
  while i < text.len:
    for j, s in sep:
      if text[i..text.high].startsWith s:
        if i > lastMatch: yield (text[lastMatch ..< i], false)
        yield (s, true)
        lastMatch = i + s.len
        i += s.high
        break
    inc i
  if i > lastMatch: yield (text[lastMatch ..< i], false)

for token, isSep in "a!===b=!=c".tokenize(["==", "!=", "="]):
  if isSep: stdout.write '{',token,'}'
  else:     stdout.write     token
echo ""


sub multisplit {
   my ($sep, $string, %opt) = @_ ;
   $sep = join '|', map quotemeta($_), @$sep;
   $sep = "($sep)" if $opt{keep_separators};
   split /$sep/, $string, -1;
}

print "'$_' " for multisplit ['==','!=','='], "a!===b=!=c";
print "\n";
print "'$_' " for multisplit ['==','!=','='], "a!===b=!=c", keep_separators => 1;
print "\n";


with javascript_semantics
procedure multisplit(string text, sequence delims)
    integer k = 1, kdx
    while true do
        integer kmin = 0
        for i=1 to length(delims) do
            integer ki = match(delims[i],text,k)
            if ki!=0 then
                if kmin=0 or ki<kmin then
                    kmin = ki
                    kdx = i
                end if
            end if
        end for
        string token = text[k..kmin-1],
               delim = iff(kmin=0?"":sprintf(", delimiter (%s) at %d",{delims[kdx],kmin}))
        printf(1,"Token: [%s] at %d%s\n",{token,k,delim})
        if kmin=0 then exit end if
        k = kmin+length(delims[kdx])
    end while
end procedure

multisplit("a!===b=!=c",{"==","!=","="})


(de multisplit (Str Sep)
   (setq Sep (mapcar chop Sep))
   (make
      (for (S (chop Str) S)
         (let L
            (make
               (loop
                  (T (find head Sep (circ S))
                     (link
                        (list
                           (- (length Str) (length S))
                           (pack (cut (length @) 'S)) ) ) )
                  (link (pop 'S))
                  (NIL S (link NIL)) ) )
            (link (pack (cdr (rot L))))
            (and (car L) (link @)) ) ) ) )

(println (multisplit "a!===b=!=c" '("==" "!=" "=")))
(println (multisplit "a!===b=!=c" '("=" "!=" "==")))


$string = "a!===b=!=c"
$separators = [regex]"(==|!=|=)"

$matchInfo = $separators.Matches($string) |
    Select-Object -Property Index, Value |
    Group-Object  -Property Value |
    Select-Object -Property @{Name="Separator"; Expression={$_.Name}},
                            Count,
                            @{Name="Position" ; Expression={$_.Group.Index}}

$matchInfo


DEFINE PTR="CARD"
DEFINE OBJSIZE="4"
TYPE Record=[BYTE b CHAR c INT i]

PROC PrintObjects(PTR ARRAY items BYTE count)
  Record POINTER r
  BYTE n

  FOR n=0 TO count-1
  DO
    r=items(n)
    PrintF("(%B ""%C"" %I) ",r.b,r.c,r.i)
    IF n MOD 3=2 THEN PutE() FI
  OD
  PutE()
RETURN

PROC Main()
  DEFINE MIN="1"
  DEFINE MAX="20"
  DEFINE BUFSIZE="80"
  BYTE ARRAY buffer(BUFSIZE)
  PTR ARRAY items(MAX)
  BYTE count=[0],n,LMARGIN=$52,oldLMARGIN
  Record POINTER r

  oldLMARGIN=LMARGIN
  LMARGIN=0 ;remove left margin on the screen
  Put(125) PutE() ;clear the screen

  WHILE count<min OR count>max
  DO
    PrintF("How many objects (%I-%I)?",MIN,MAX)
    count=InputB()
  OD

  FOR n=0 TO count-1
  DO
    items(n)=buffer+n*OBJSIZE
  OD

  PutE()
  PrintE("Uninitialized objects:")
  PrintObjects(items,count)

  FOR n=0 TO count-1
  DO
    r=items(n)
    r.b=n r.c=n+'A r.i=-n
  OD

  PutE()
  PrintE("Initialized objects:")
  PrintObjects(items,count)

  LMARGIN=oldLMARGIN ;restore left margin on the screen
RETURN


void
show_sublist(list l)
{
    integer i, v;

    for (i, v in l) {
        o_space(sign(i));
        o_integer(v);
    }
}

void
show_list(list l)
{
    integer i;
    list v;

    for (i, v in l) {
        o_text(" [");
        show_sublist(v);
        o_text("]");
    }

    o_byte('\n');
}

list
multiple_distinct(integer n, object o)
{
    list l;

    call_n(n, l_append, l, o);

    return l;
}

integer
main(void)
{
    list l, z;

    # create a list of integers - `3' will serve as initializer
    l = multiple_distinct(8, 3);

    l_clear(l);

    # create a list of distinct lists - `z' will serve as initializer
    l_append(z, 4);
    l = multiple_distinct(8, z);

    # modify one of the sublists
    l_q_list(l, 3)[0] = 7;

    # display the list of lists
    show_list(l);

    return 0;
}


MODE FOO = STRUCT(CHAR u,l);
INT n := 26;
[n]FOO f;

# Additionally each item can be initialised #
FOR i TO UPB f DO f[i] := (REPR(ABS("A")-1+i), REPR(ABS("a")-1+i))  OD;

print((f, new line))


begin
    record    T  ( integer n, m );
    reference(T) singleT;
    integer      numberOfElements;
    singleT          := T( 0, 0 );
    numberOfElements := 3;
    begin
        reference(T) array tArray ( 1 :: numberOfElements );
        % initialise the "right" way            %
        for i := 1 until numberOfElements do begin
            tArray( i )    := T( i, i * 2 );
            m(tArray( i )) := m(tArray( i )) + 1;
        end for_i ;
        write();
        for i := 1 until numberOfElements do writeon( i_w := 1, s_w := 0, n(tArray( i )), ", ", m(tArray( i )), "; " );
        % initialise the "wrong" way            %
        for i := 1 until numberOfElements do begin
            tArray( i )    := singleT;
            m(tArray( i )) := m(tArray( i )) + 1;
        end for_i ;
        write();
        for i := 1 until numberOfElements do writeon( i_w := 1, s_w := 0, n(tArray( i )), ", ", m(tArray( i )), "; " )
    end
end.


-- MULTIPLE DISTINCT OBJECTS -------------------------------------------------

-- nObjects Constructor -> Int -> [Object]
on nObjects(f, n)
    map(f, enumFromTo(1, n))
end nObjects

-- TEST ----------------------------------------------------------------------
on run
    -- someConstructor :: a -> Int -> b
    script someConstructor
        on |λ|(_, i)
            {index:i}
        end |λ|
    end script

    nObjects(someConstructor, 6)

    --> {{index:1}, {index:2}, {index:3}, {index:4}, {index:5}, {index:6}}
end run

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

-- enumFromTo :: Int -> Int -> [Int]
on enumFromTo(m, n)
    if m > n then
        set d to -1
    else
        set d to 1
    end if
    set lst to {}
    repeat with i from m to n by d
        set end of lst to i
    end repeat
    return lst
end enumFromTo

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

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


multisplit(_LSep, '') -->
	{!},
	[].

multisplit(LSep, T) -->
	{next_sep(LSep, T, [], Token, Sep, T1)},
	(   {Token \= '' },[Token], {!}; []),
	(   {Sep \= '' },[Sep], {!}; []),
	multisplit(LSep, T1).

next_sep([], T, Lst, Token, Sep, T1) :-
	% if we can't find any separator, the game is over
	(   Lst = [] ->
	Token = T, Sep = '', T1 = '';

	% we sort the list to get nearest longest separator
	predsort(my_sort, Lst, [(_,_, Sep)|_]),
	atomic_list_concat([Token|_], Sep, T),
	atom_concat(Token, Sep, Tmp),
	atom_concat(Tmp, T1, T)).

next_sep([HSep|TSep], T, Lst, Token, Sep, T1) :-
	sub_atom(T, Before, Len, _, HSep),
	next_sep(TSep, T, [(Before, Len,HSep) | Lst], Token, Sep, T1).

next_sep([_HSep|TSep], T, Lst, Token, Sep, T1) :-
	next_sep(TSep, T, Lst, Token, Sep, T1).

my_sort(<, (N1, _, _), (N2, _, _)) :-
	N1 < N2.

my_sort(>, (N1, _, _), (N2, _, _)) :-
	N1 > N2.

my_sort(>, (N, N1, _), (N, N2, _)) :-
	N1 < N2.

my_sort(<, (N, N1, _), (N, N2, _)) :-
	N1 > N2.


a := []
Loop, %n%
   a[A_Index] := new Foo()


      REM Determine object count at runtime:
      n% = RND(1000)

      REM Declare an array of structures; all members are initialised to zero:
      DIM objects{(n%) a%, b$}

      REM Initialise the objects to distinct values:
      FOR i% = 0 TO DIM(objects{()},1)
        objects{(i%)}.a% = i%
        objects{(i%)}.b$ = STR$(i%)
      NEXT

      REM This is how to create an array of pointers to the same object:
      DIM objects%(n%), object{a%, b$}
      FOR i% = 0 TO DIM(objects%(),1)
        objects%(i%) = object{}
      NEXT


foo *foos = malloc(n * sizeof(*foos));
for (int i = 0; i < n; i++)
  init_foo(&foos[i]);


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

List<Foo> foos = Enumerable.Range(1, n).Select(x => new Foo()).ToList();


// this assumes T is a default-constructible type (all built-in types are)
T* p = new T[n]; // if T is POD, the objects are uninitialized, otherwise they are default-initialized

//If default initialisation is not what you want, or if T is a POD type which will be uninitialized
for(size_t i = 0; i != n; ++i)
   p[i] = make_a_T(); //or some other expression of type T

// when you don't need the objects any more, get rid of them
delete[] p;


sub multisplit($str, @seps) { $str.split(/ ||@seps /, :v) }

my @chunks = multisplit( 'a!===b=!=c==d', < == != = > );

# Print the strings.
say @chunks».Str.raku;

# Print the positions of the separators.
for grep Match, @chunks -> $s {
    say "  $s   from $s.from() to $s.to()";
}


(make-list n :initial-element (make-the-distinct-thing))
(make-array n :initial-element (make-the-distinct-thing))


auto fooArray = new Foo[n];
foreach (ref item; fooArray)
    item = new Foo();


var
  i: Integer;
  lObject: TMyObject;
  lList: TObjectList<TMyObject>;
begin
  lList := TObjectList<TMyObject>.Create;
  lObject := TMyObject.Create;
  for i := 1 to 10 do
    lList.Add(lObject);
  // ...


pragma.enable("accumulator")
...

accum [] for _ in 1..n { _.with(makeWhatever()) }


/*REXX program  splits  a (character) string  based on different  separator  delimiters.*/
parse arg $                                      /*obtain optional string from the C.L. */
if $=''   then $= "a!===b=!=c"                   /*None specified?  Then use the default*/
say 'old string:' $                              /*display the old string to the screen.*/
null= '0'x                                       /*null char.   It can be most anything.*/
seps= '== != ='                                  /*list of separator strings to be used.*/
                                                 /* [↓]   process the tokens in  SEPS.  */
  do j=1  for words(seps)                        /*parse the string with all the seps.  */
  sep=word(seps,j)                               /*pick a separator to use in below code*/
                                                 /* [↓]   process characters in the sep.*/
        do k=1  for length(sep)                  /*parse for various separator versions.*/
        sep=strip(insert(null, sep, k), , null)  /*allow imbedded "nulls" in separator, */
        $=changestr(sep, $, null)                /*       ··· but not trailing "nulls". */
                                                 /* [↓]   process strings in the input. */
             do  until $==old;      old=$        /*keep changing until no more changes. */
             $=changestr(null || null, $, null)  /*reduce replicated "nulls" in string. */
             end   /*until*/
                                                 /* [↓]  use  BIF  or  external program.*/
        sep=changestr(null, sep, '')             /*remove true nulls from the separator.*/
        end        /*k*/
  end              /*j*/

showNull= ' {} '                                 /*just one more thing, display the ··· */
$=changestr(null, $, showNull)                   /*        ··· showing of "null" chars. */
say 'new string:' $                              /*now, display the new string to term. */
                                                 /*stick a fork in it,  we're all done. */


# Project : Multisplit

str = "a!===b=!=c"
sep = "=== != =! b =!="
sep = str2list(substr(sep, " ", nl))
for n = 1 to len(sep)
      pos = substr(str, sep[n])
      see "" + n + ": " + substr(str, 1, pos-1) + " Sep By: " + sep[n] + nl
next


text = 'a!===b=!=c'
separators = ['==', '!=', '=']

def multisplit_simple(text, separators)
  text.split(Regexp.union(separators))
end

p multisplit_simple(text, separators) # => ["a", "", "b", "", "c"]


str$ = "a!===b=!=c"
sep$ = "=== != =! b =!="

while word$(sep$,i+1," ") <> ""
 i = i + 1
 theSep$ = word$(sep$,i," ")
 split$  = word$(str$,1,theSep$)
 print i;" ";split$;" Sep By: ";theSep$
wend


;; wrong - make-vector is evaluated one time - same vector

(define L (make-list 3 (make-vector 4)))
L    → (#(0 0 0 0) #(0 0 0 0) #(0 0 0 0))
(vector-set! (first L ) 1 '🔴) ;; sets the 'first' vector

L   → (#(0 🔴 0 0) #(0 🔴 0 0) #(0 🔴 0 0))

;; right - three different vectors

(define L(map make-vector (make-list 3 4)))
L    → (#(0 0 0 0) #(0 0 0 0) #(0 0 0 0))
(vector-set! (first L ) 1 '🔵) ;; sets the first vector

L   → (#(0 🔵 0 0) #(0 0 0 0) #(0 0 0 0)) ;; OK


import system'routines;
import extensions;

class Foo;

// create a list of disting object
fill(n)
    = RangeEnumerator.new(1,n).selectBy:(x => new Foo()).toArray();

// testing
public program()
{
    var foos := fill(10);
}


randoms = for _ <- 1..10, do: :rand.uniform(1000)


Randoms = [random:uniform(1000) || _ <- lists:seq(1,10)].


import scala.annotation.tailrec
def multiSplit(str:String, sep:Seq[String])={
   def findSep(index:Int)=sep find (str startsWith (_, index))
   @tailrec def nextSep(index:Int):(Int,Int)=
      if(index>str.size) (index, 0) else findSep(index) match {
         case Some(sep) => (index, sep.size)
         case _ => nextSep(index + 1)
      }
   def getParts(start:Int, pos:(Int,Int)):List[String]={
      val part=str slice (start, pos._1)
      if(pos._2==0) List(part) else part :: getParts(pos._1+pos._2, nextSep(pos._1+pos._2))
   }
   getParts(0, nextSep(0))
}

println(multiSplit("a!===b=!=c", Seq("!=", "==", "=")))


(use srfi-13)
(use srfi-42)

(define (shatter separators the-string)
  (let loop ((str the-string) (tmp ""))
    (if (string=? "" str)
      (list tmp)
      (if-let1 sep (find (^s (string-prefix? s str)) separators)
        (cons* tmp sep
          (loop (string-drop str (string-length sep)) ""))
        (loop (string-drop str 1) (string-append tmp (string-take str 1)))))))

(define (glean shards)
  (list-ec (: x (index i) shards)
    (if (even? i)) x))


set source to "a!===b=!=c"
set separators to ["==", "!=", "="]

put each line delimited by separators of source


include FMS-SI.f
include FMS-SILib.f

\ create a list of VAR objects the right way
\ each: returns a unique object reference
o{ 0 0 0 } dup p:   o{ 0 0 0 }
dup each: drop . 10774016
dup each: drop . 10786896
dup each: drop . 10786912

\ create a list of VAR objects the wrong way
\ each: returns the same object reference
var x
object-list2 list
x list add:
x list add:
x list add:
list p: o{ 0 0 0 }
list each: drop . 1301600
list each: drop . 1301600
list each: drop . 1301600


program multiple
  ! Define a simple type
  type T
     integer :: a = 3
  end type T

  ! Define a type containing a pointer
  type S
     integer, pointer :: a
  end type S

  type(T), allocatable :: T_array(:)
  type(S), allocatable :: S_same(:)
  integer              :: i
  integer, target      :: v
  integer, parameter   :: N = 10

  ! Create 10
  allocate(T_array(N))

  ! Set the fifth one to b something different
  T_array(5)%a = 1

  ! Print them out to show they are distinct
  write(*,'(10i2)') (T_array(i),i=1,N)

  ! Create 10 references to the same object
  allocate(S_same(N))
  v = 5
  do i=1, N
     allocate(S_same(i)%a)
     S_same(i)%a => v
  end do

  ! Print them out - should all be 5
  write(*,'(10i2)') (S_same(i)%a,i=1,N)

  ! Change the referenced object and reprint - should all be 3
  v = 3
  write(*,'(10i2)') (S_same(i)%a,i=1,N)

end program multiple


func nxm(n, m int) [][]int {
    d2 := make([][]int, n)
    for i := range d2 {
        d2[i] = make([]int, m)
    }
    return d2
}


func multisplit(sep, str, keep_sep=false) {
    sep = sep.map{.escape}.join('|');
    var re = Regex.new(keep_sep ? "(#{sep})" : sep);
    str.split(re, -1);
}

[false, true].each { |bool|
    say multisplit(%w(== != =), 'a!===b=!=c', keep_sep: bool);
}


extension String {
  func multiSplit(on seps: [String]) -> ([Substring], [(String, (start: String.Index, end: String.Index))]) {
    var matches = [Substring]()
    var matched = [(String, (String.Index, String.Index))]()
    var i = startIndex
    var lastMatch = startIndex

    main: while i != endIndex {
      for sep in seps where self[i...].hasPrefix(sep) {
        if i > lastMatch {
          matches.append(self[lastMatch..<i])
        } else {
          matches.append("")
        }

        lastMatch = index(i, offsetBy: sep.count)
        matched.append((sep, (i, lastMatch)))
        i = lastMatch

        continue main
      }

      i = index(i, offsetBy: 1)
    }

    if i > lastMatch {
      matches.append(self[lastMatch..<i])
    }

    return (matches, matched)
  }
}

let (matches, matchedSeps) = "a!===b=!=c".multiSplit(on: ["==", "!=", "="])

print(matches, matchedSeps.map({ $0.0 }))


proc simplemultisplit {text sep} {
    set map {}; foreach s $sep {lappend map $s "\uffff"}
    return [split [string map $map $text] "\uffff"]
}
puts [simplemultisplit "a!===b=!=c" {"==" "!=" "="}]


@(next :args)
@(coll :gap 0)@(choose :shortest tok)@\
                @[email protected]{sep /==/}@\
              @(or)@\
                @[email protected]{sep /!=/}@\
              @(or)@\
                @[email protected]{sep /=/}@\
              @(end)@(end)@tail
@(output)
@(rep)"@tok" {@sep} @(end)"@tail"
@(end)


multisplit() {
    local str=$1
    shift
    local regex=$( IFS='|'; echo "$*" )
    local sep
    while [[ $str =~ $regex ]]; do
        sep=${BASH_REMATCH[0]}
        words+=( "${str%%${sep}*}" )
        seps+=( "$sep" )
        str=${str#*$sep}
    done
    words+=( "$str" )
}

words=() seps=()

original="a!===b=!=c"
recreated=""

multisplit "$original" "==" "!=" "="

for ((i=0; i<${#words[@]}; i++)); do
    printf 'w:"%s"\ts:"%s"\n' "${words[i]}" "${seps[i]}"
    recreated+="${words[i]}${seps[i]}"
done

if [[ $original == $recreated ]]; then
    echo "successfully able to recreate original string"
fi


def createFoos1 = { n -> (0..<n).collect { new Foo() } }


  items_wrong := list (10, [])
  # prints '0' for size of each item
  every item := !items_wrong do write (*item)
  # after trying to add an item to one of the lists
  push (items_wrong[1], 2)
  # now prints '1' for size of each item
  every item := !items_wrong do write (*item)


Foo[] foos = new Foo[n]; // all elements initialized to null
for (int i = 0; i < foos.length; i++)
    foos[i] = new Foo();

// incorrect version:
Foo[] foos_WRONG = new Foo[n];
Arrays.fill(foos, new Foo());  // new Foo() only evaluated once


Function multisplit(s,sep)
	arr_sep = Split(sep,"|")
	For i = 0 To UBound(arr_sep)
		arr_s = Split(s,arr_sep(i))
		s = Join(arr_s,",")
	Next
	multisplit = s
End Function

Function multisplit_extra(s,sep)
	Set dict_sep = CreateObject("Scripting.Dictionary")
	arr_sep = Split(sep,"|")
	For i = 0 To UBound(arr_sep)
		dict_sep.Add i,"(" & arr_sep(i) & ")"
		arr_s = Split(s,arr_sep(i))
		s = Join(arr_s,i)
	Next
	For Each key In dict_sep.Keys
		s = Replace(s,key,dict_sep.Item(key))
	Next
	multisplit_extra = s
End Function

WScript.StdOut.Write "Standard: " & multisplit("a!===b=!=c","!=|==|=")
WScript.StdOut.WriteLine
WScript.StdOut.Write "Extra Credit: " & multisplit_extra("a!===b=!=c","!=|==|=")
WScript.StdOut.WriteLine


import "/pattern" for Pattern
import "/fmt" for Fmt

var input = "a!===b=!=c"
var p = Pattern.new("[/=/=|!/=|/=]")
var separators = p.findAll(input)
System.print("The separators matched and their starting/ending indices are:")
for (sep in separators) {
    System.print("  %(Fmt.s(-4, Fmt.q(sep.text))) between %(sep.span)")
}
var parts = p.splitAll(input)
System.print("\nThe substrings between the separators are:")
System.print(parts.map { |p| (p != "") ? Fmt.q(p) : "empty string" }.toList)


t$ = "a!===b=!=c"
s$ = "==,!=,="

dim n$(1)

n = token(s$, n$(), ",")
dim p(n)

do
    l = len(t$)
    j = 0
    for i = 1 to n
        p(i) = instr(t$, n$(i))
        if p(i) and p(i) < l then l = p(i) : j = i end if
    next
    if not j print t$ : break
    print left$(t$, l - 1), " with separator ", n$(j)
    t$ = right$(t$, len(t$) - (l + len(n$(j))) + 1)
loop