Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]

Groups > comp.lang.forth > #27410 > unrolled thread

Josephus Circle problem

Back to article view | Back to comp.lang.forth

Contents

  Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-23 19:12 -0800
    Re: Josephus Circle problem "Rod Pemberton" <dont_use_email@xnohavenotit.cnm> - 2013-12-24 02:49 -0500
      Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-24 01:13 -0800
        Re: Josephus Circle problem mhx@iae.nl - 2013-12-24 02:17 -0800
          Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 03:45 -0800
            Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-24 04:25 -0800
              Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 04:25 -0800
                Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-24 04:52 -0800
              Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-24 14:57 +0000
              Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-25 20:15 +1100
            Re: Josephus Circle problem mhx@iae.nl - 2013-12-24 04:36 -0800
        Re: Josephus Circle problem "Rod Pemberton" <dont_use_email@xnohavenotit.cnm> - 2013-12-24 17:05 -0500
        Re: Josephus Circle problem "WJ" <w_a_x_man@yahoo.com> - 2014-03-10 07:11 +0000
      Re: Josephus Circle problem mhx@iae.nl - 2013-12-24 02:59 -0800
    Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 01:53 -0800
      Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-24 04:06 -0800
        Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 04:24 -0800
    Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 04:30 -0800
      Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 04:35 -0800
    Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 05:01 -0800
      Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-24 05:34 -0800
        Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-24 05:22 -0800
        Re: Josephus Circle problem "Elizabeth D. Rather" <erather@forth.com> - 2013-12-24 13:25 -1000
          Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-25 20:40 +1100
            Re: Josephus Circle problem "Elizabeth D. Rather" <erather@forth.com> - 2013-12-25 09:37 -1000
              Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-26 03:19 -0800
                Re: Josephus Circle problem "Elizabeth D. Rather" <erather@forth.com> - 2013-12-26 12:01 -1000
              Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-27 12:33 +1100
                Re: Josephus Circle problem Elizabeth D Rather <erather@forth.com> - 2013-12-26 17:41 -1000
                  Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-27 18:46 +1100
                    Re: Josephus Circle problem Mark Wills <markrobertwills@yahoo.co.uk> - 2013-12-27 02:46 -0800
                      Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-27 13:16 +0000
                        Re: Josephus Circle problem mhx@iae.nl - 2013-12-27 05:27 -0800
                          Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-27 14:15 +0000
                        Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-29 21:56 +1100
                          Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-29 12:37 +0000
                            Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-30 00:47 +1100
                      Re: Josephus Circle problem "Ed" <invalid@invalid.com> - 2013-12-29 14:08 +1100
                Re: Josephus Circle problem Mark Wills <markrobertwills@yahoo.co.uk> - 2013-12-27 02:35 -0800
                  Re: Josephus Circle problem Mark Wills <markrobertwills@yahoo.co.uk> - 2013-12-27 02:43 -0800
                  Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-27 19:00 +0000
      Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-24 15:59 +0000
    Re: Josephus Circle problem Gerry Jackson <spam@qlikz.org> - 2013-12-24 20:07 +0000
      Re: Josephus Circle problem albert@spenarnc.xs4all.nl (Albert van der Horst) - 2013-12-24 20:31 +0000
      Re: Josephus Circle problem mhx@iae.nl - 2013-12-25 04:38 -0800
        Re: Josephus Circle problem mhx@iae.nl - 2013-12-25 06:04 -0800
        Re: Josephus Circle problem mhx@iae.nl - 2013-12-25 06:06 -0800
          Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-25 23:08 -0800
            Re: Josephus Circle problem ForthFreak <forthfreak@gmail.com> - 2013-12-26 03:31 -0800
          Re: Josephus Circle problem Gerry Jackson <spam@qlikz.org> - 2013-12-26 10:52 +0000
            Re: Josephus Circle problem Tristan Plumb <firth@trstn.net> - 2013-12-26 14:37 +0000
              Re: Josephus Circle problem Paul Rubin <no.email@nospam.invalid> - 2013-12-26 07:12 -0800
            Re: Josephus Circle problem Gerry Jackson <spam@qlikz.org> - 2013-12-26 17:31 +0000
          Re: Josephus Circle problem Ron Aaron <rambamist@gmail.com> - 2013-12-26 21:39 +0200
      Re: Josephus Circle problem anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2013-12-26 17:33 +0000

Page 3 of 3 — ← Prev page 1 2 [3]

#27480

In article <ee097b83-3f6d-476e-b745-a5c69770dc4c@googlegroups.com>,
Mark Wills  <markrobertwills@yahoo.co.uk> wrote:
>On Friday, December 27, 2013 1:33:16 AM UTC, Ed wrote:
>>
>> <snip>Data space created with ALLOT can always be un-ALLOTed after the
>> program is run.
>
>Really? How? As far as I know, there is no standard way to get that
>memory back. ALLOT moves the current compilation address, and then the
>program is compiled after the alloted data. That data space is gone, as
>far as the rest of the system is concerned.

As far as I can tell that is allowed and established practice.
For example, I can do  HERE HUGE ALLOT , then read a file at
the address, and trim it back.

What I do in my class implementation:
I set HERE to a temporary location and build a sample datastructure
to determine offsets, then put HERE back.

The standard says that ALLOT can used to "reinitialise the data
space"
-- 
Albert van der Horst, UTRECHT,THE NETHERLANDS
Economic growth -- being exponential -- ultimately falters.
albert@spe&ar&c.xs4all.nl &=n http://home.hccnet.nl/a.w.m.van.der.horst

[toc] | [prev] | [next] | [standalone]

#27432

In article <03b7bcda-141f-464d-87bf-4151a56fe36e@googlegroups.com>,
ForthFreak  <forthfreak@gmail.com> wrote:
>With a slight change to use PAD. This allows one to try different circle
>sizes without need for re-compilation.
>
<SNIP>

Another way is to use stacks, two stacks count for a circular buffer.
I've some loadable stack utility, but here we get by with the return
stack.

Using the Stallman convention. Uppercase words indicate stack items.

\ -------------------------8< --------------------------------
\ The Josephus ring problem.

3 CONSTANT #dec
VARIABLE standing
VARIABLE count

\ For N create an army of n soldiers on the stack.
: army   0 SWAP BEGIN DUP 1- ?DUP WHILE REPEAT ;

\ Shove the army to the return stack while decimating, and back.
: decimate-row-and-back
    0 >R   \ sentinel
    BEGIN
        1 count +!
        count @ #dec MOD IF >R ELSE DROP -1 standing +! THEN
    ?DUP WHILE REPEAT
    0 BEGIN R> ?DUP WHILE REPEAT ;

\ Decimate an army of N man. Leave the last MAN standing.
: decimate   DUP >R army   R> standing !  0 count !
    BEGIN decimate-row-and-back  standing @ 1 = UNTIL
    NIP ;

\ ciforth specific -------------------

: doit
   3 ARGC = IF 2 ARG[] EVALUATE '#dec >DFA ! THEN
   1 ARG[] EVALUATE decimate
   "the last man standing is : " TYPE . CR
;
\ -------------------------8< --------------------------------

I got the algorithm right the first time, except for
`` -1 standing ! '' instead of `` -1 standing +! ''  !
I chalk that down as a typo.

Usage is :   40 decimate .

You may replace DROP in decimate-row-and-back by a . to see
which soldiers gets it.

If you use ciforth your can compile:
   lina -c lastman.frt
and then
   lastman 40
or even you can patch the data field of the constant #dec
   lastman 40 7
(decimating one in 7 ).

P.S. The habit in the Roman army was to decimate one in ten,
(hence decimate). Then stop after one round, such that
90% of the army survived. Killing the whole army is somewhat
counterproductive.

>
>Okay, that's enough Forth for Christmas eve ;-)

Yeah, I'm going to do C now for eulerproblem 451.
(I've solved it in Forth, but I have an alternative fast
algorithm and I want to show off its speed.)

Groetjes Albert
-- 
Albert van der Horst, UTRECHT,THE NETHERLANDS
Economic growth -- being exponential -- ultimately falters.
albert@spe&ar&c.xs4all.nl &=n http://home.hccnet.nl/a.w.m.van.der.horst

[toc] | [prev] | [next] | [standalone]

#27435

On 24/12/2013 03:12, Paul Rubin wrote:
> This is an oldie that was in Knuth vol 2 though I don't have the
> reference handy.  Also at:
>
> http://thedailywtf.com/Articles/Programming-Praxis-Josephus-Circle.aspx
> http://mathworld.wolfram.com/JosephusProblem.html
>
>  From the first url: "In order to decide who would die in which order,
> the soldiers stood in a circle and, starting with the top of the circle
> and continuing clockwise, counted to three. The third man got the ax and
> the counting resumed at one. The process continued until there was no
> one left. Josephus, who didn't quite agree with the whole "we should all
> kill ourselves" idea, figured out the perfect way to avoid death: be the
> last man standing."
>
> Problem: There are 40 soldiers to start with, number 1,2,3,... .
> Calculate the order in which they are killed.
>
> A solution:
> ================================================================
>
> 40 constant ring-size
> 3 constant jump-size
> jump-size 1- constant jump-size-1
>
> create ring  ring-size cells allot
> does> ( i -- addr ) swap cells + ;
>
> variable remaining                      \ number of men still alive
> variable p                              \ place to start counting from
> : decr-remaining ( -- ) remaining @ 1- remaining ! ;
>
> : init-ring ( -- ) ring-size 0 do i 1+ i ring ! loop ;
> : init-vars ( -- ) ring-size remaining !   0 p ! ;
> : init ( -- ) init-ring init-vars ;
> : next-p ( -- ) p @ jump-size-1 + remaining @ mod p ! ;
>
> : cells-to-move ( -- n ) remaining @ p @ - 1- ;
> : remove ( -- ) p @ 1+ ring  p @ ring  cells-to-move cells  move ;
>
> : show ( n -- ) ring @ . ;
> : iteration ( -- ) next-p p @ dup show remove decr-remaining ;
> : run ( -- ) cr init begin remaining @ while iteration repeat cr ;
>
> run
> ================================================================
>

For amusement only - a pure stack solution (uses the hated ROLL):

: recruit  ( u -- 1 2 ... u )  1+ 1 do i loop ;

: kill-soldier  (  u1 u2 u3 u4 ... u5 -- u4 ... u5 u1 u2 )
    3 0 do depth 1- roll loop drop
;

: last-man  ( 1 2 ... u -- u2 )
    depth 1- 0 do kill-soldier loop
;

: go  ( n -- )  recruit last-man ." Last man: " . ;

40 go

It can be done with the stack the other way round i.e.
( 40 39 ... 1 ) and use rot drop to kill, but that takes a bit more code.

-- 
Gerry

[toc] | [prev] | [next] | [standalone]

#27436

In article <l9cpi3$gt9$1@dont-email.me>, Gerry Jackson  <spam@qlikz.org> wrote:
>On 24/12/2013 03:12, Paul Rubin wrote:
>> This is an oldie that was in Knuth vol 2 though I don't have the
>> reference handy.  Also at:
>>
>> http://thedailywtf.com/Articles/Programming-Praxis-Josephus-Circle.aspx
>> http://mathworld.wolfram.com/JosephusProblem.html
>>
>>  From the first url: "In order to decide who would die in which order,
>> the soldiers stood in a circle and, starting with the top of the circle
>> and continuing clockwise, counted to three. The third man got the ax and
>> the counting resumed at one. The process continued until there was no
>> one left. Josephus, who didn't quite agree with the whole "we should all
>> kill ourselves" idea, figured out the perfect way to avoid death: be the
>> last man standing."
>>
>> Problem: There are 40 soldiers to start with, number 1,2,3,... .
>> Calculate the order in which they are killed.

>For amusement only - a pure stack solution (uses the hated ROLL):
>
>: recruit  ( u -- 1 2 ... u )  1+ 1 do i loop ;
>
>: kill-soldier  (  u1 u2 u3 u4 ... u5 -- u4 ... u5 u1 u2 )
>    3 0 do depth 1- roll loop drop
>;
>
>: last-man  ( 1 2 ... u -- u2 )
>    depth 1- 0 do kill-soldier loop
>;
>
>: go  ( n -- )  recruit last-man ." Last man: " . ;

>
>40 go
>
>It can be done with the stack the other way round i.e.
>( 40 39 ... 1 ) and use rot drop to kill, but that takes a bit more code.

Nice. It is a contender for "solve the problem with the least WOC
using only standard words". And a vindication for ROLL.
A small blemish is that the stack must be empty to start with
otherwise you'll kill soldiers of the enemy, which can't be
the intention.

>
>--
>Gerry

Groetjes Albert
-- 
Albert van der Horst, UTRECHT,THE NETHERLANDS
Economic growth -- being exponential -- ultimately falters.
albert@spe&ar&c.xs4all.nl &=n http://home.hccnet.nl/a.w.m.van.der.horst

[toc] | [prev] | [next] | [standalone]

#27441

On Tuesday, December 24, 2013 9:07:19 PM UTC+1, Gerry Jackson wrote:
> On 24/12/2013 03:12, Paul Rubin wrote:
> 
> > This is an oldie that was in Knuth vol 2 though I don't have the
> > reference handy.  Also at:

Much too verbose. Here is a one-liner (given the appropriate terminal):

: .sweetspot  0  #40 2^x 1-  begin  #40 0 do  dup i 2^x and if  swap 1+ dup 3 = if drop 0 swap  i 2^x xor  else swap  endif  endif  loop  dup power-of-2?  until nip log2 1+ . ;

I am sure y'all have 2^x POWER-OF-2? and LOG2 (Classics!).

-marcel

[toc] | [prev] | [next] | [standalone]

#27442

On Wednesday, December 25, 2013 1:38:38 PM UTC+1, m...@iae.nl wrote:
> On Tuesday, December 24, 2013 9:07:19 PM UTC+1, Gerry Jackson wrote:
> 
> > On 24/12/2013 03:12, Paul Rubin wrote:
> > > This is an oldie that was in Knuth vol 2 though I don't have the
> > > reference handy.  Also at:
> 
> Much too verbose. Here is a one-liner (given the appropriate terminal):
> 
> : .sweetspot  0  #40 2^x 1-  begin  #40 0 do  dup i 2^x and if  swap 1+ dup 3 = if drop 0 swap  i 2^x xor  else swap  endif  endif  loop  dup power-of-2?  until nip log2 1+ . ;
> 
> : josephus 0 1 begin dup #40 <= while swap 3 + over mod swap 1+ repeat drop 1+ . ; 
> 
> -marcel

[toc] | [prev] | [next] | [standalone]

#27443

On Wednesday, December 25, 2013 1:38:38 PM UTC+1, m...@iae.nl wrote:
> Much too verbose. Here is a one-liner (given the appropriate terminal):
> [..deleted convoluted ugliness..]

: josephus 0 1 begin dup #40 <= while  swap 3 + over mod swap  1+ repeat drop 1+ . ;

-marcel

[toc] | [prev] | [next] | [standalone]

#27446

mhx@iae.nl writes:
> : josephus 0 1 begin dup #40 <= while  swap 3 + over mod swap  1+ repeat drop 1+ . ;

I'm trying to wrap my head around this.  Wow!

[toc] | [prev] | [next] | [standalone]

#27451

On Thursday, 26 December 2013 07:08:41 UTC, Paul Rubin  wrote:
> I'm trying to wrap my head around this.  Wow!

I'm with you Paul. 62 bytes on my system. This is so utterly awesome I think I need to go for a little lie down! 

Must be the eggnog ;-)

[toc] | [prev] | [next] | [standalone]

#27449

On 25/12/2013 14:06, mhx@iae.nl wrote:
> On Wednesday, December 25, 2013 1:38:38 PM UTC+1, m...@iae.nl wrote:
>> Much too verbose. Here is a one-liner (given the appropriate terminal):
>> [..deleted convoluted ugliness..]
>
> : josephus 0 1 begin dup #40 <= while  swap 3 + over mod swap  1+ repeat drop 1+ . ;
>
> -marcel
>
Or, to link up with the quotations discussion, and as long as your 
stacks are big enough

: josephus  [: dup 1 <> if dup 1- recurse 2 + swap mod 1+ then ;] 
execute . ;

usage:
40 josephus

-- 
Gerry

[toc] | [prev] | [next] | [standalone]

#27456

On 2013-12-26, Gerry Jackson <spam@qlikz.org> wrote:
> Or, to link up with the quotations discussion, and as long as your 
> stacks are big enough

I've been trying to explain my take on quotations, thank you!

>: josephus  [: dup 1 <> if dup 1- recurse 2 + swap mod 1+ then ;] 
> execute . ;
>
> usage:
> 40 josephus

On the one hand the above looks more like bad factoring:

: josephus dup 1 <> if dup 1- recurse 2 + swap mod 1+ then ;

usage:
40 josephus .

However! Combinators can do amazing things with quotations. Take nrec:
Given f(0) and a function for f(n-1), find f(n). (Like Joy's primrec.)

: nrec ( n F F0 -- Fn ) rot 1+ 1 do over i swap execute loop nip ;

Yielding:

: josephus [: swap 2 + swap mod 1+ ;] 1 nrec ;

Which is just as understandable as, but not quite so testable as:

: (josephus) swap 2 + swap mod 1+ ;
: josephus ' (josephus) 1 nrec ;

Tristan

[toc] | [prev] | [next] | [standalone]

#27457

Tristan Plumb <firth@trstn.net> writes:
> However! Combinators can do amazing things with quotations. Take nrec:...
> : nrec ( n F F0 -- Fn ) rot 1+ 1 do over i swap execute loop nip ;

Neat ;-)

> : (josephus) swap 2 + swap mod 1+ ;
> : josephus ' (josephus) 1 nrec ;

' should say ['] .

The Haskell equivalent of Marcel's algorithm is:

  josephus k n = 1 + foldl (\a b->(a+k)`mod`b) 0 [1..n]

I guess it's possible to concoct a reduce combinator in Forth, but it
just doesn't seem in the Forth style.  It would also want to use a
coroutine to generate the input stream.

[toc] | [prev] | [next] | [standalone]

#27458

On 26/12/2013 10:52, Gerry Jackson wrote:
> On 25/12/2013 14:06, mhx@iae.nl wrote:
>> On Wednesday, December 25, 2013 1:38:38 PM UTC+1, m...@iae.nl wrote:
>>> Much too verbose. Here is a one-liner (given the appropriate terminal):
>>> [..deleted convoluted ugliness..]
>>
>> : josephus 0 1 begin dup #40 <= while  swap 3 + over mod swap  1+
>> repeat drop 1+ . ;
>>
>> -marcel
>>
> Or, to link up with the quotations discussion, and as long as your
> stacks are big enough
>
> : josephus  [: dup 1 <> if dup 1- recurse 2 + swap mod 1+ then ;]
> execute . ;
>
> usage:
> 40 josephus
>

Just in case anyone is wondering, this was adapted from
http://en.wikipedia.org/wiki/Josephus_problem
which also contains Marcel's algorithm, and explains it.

-- 
Gerry

[toc] | [prev] | [next] | [standalone]

#27463

Thanks for an interesting diversion.

Here's that algorithm, coded in 8th:

\ Number of men:
var n

\ "kill-skip":
var k

: josephus-round \ r i
	swap k @ N:+
	over N:%
	swap N:1+
	dup n @ N:> if ;; then
	josephus-round ;

: josephus \ n k
	k ! n !
	0 1 josephus-round drop N:1+ ;

\ do the actual calculation:
40 3 josephus

"The number of the last man standing out of " .  n @ .
", killing each " .  k @ .
" is: " .  .
cr bye

[toc] | [prev] | [next] | [standalone]

#27459

Gerry Jackson <spam@qlikz.org> writes:
>For amusement only - a pure stack solution (uses the hated ROLL):
>
>: recruit  ( u -- 1 2 ... u )  1+ 1 do i loop ;
>
>: kill-soldier  (  u1 u2 u3 u4 ... u5 -- u4 ... u5 u1 u2 )
>    3 0 do depth 1- roll loop drop
>;
>
>: last-man  ( 1 2 ... u -- u2 )
>    depth 1- 0 do kill-soldier loop
>;
>
>: go  ( n -- )  recruit last-man ." Last man: " . ;
>
>40 go

I had the same idea, and coded it without looking at your solution
(took me 8 minutes including debugging):

40 constant soldiers

: init soldiers 0 do i 1+ loop ;
: josephus-circle ( -- )
    init
    0 soldiers 1- do
	i roll i roll i roll .
    -1 +loop ;

This one does not use DEPTH.

What do we learn from this?  This kind of mathematical problem is
sufficiently different from real-world problems that we use
programming techniques successfully that we do not use for real-world
programs, because they don't scale.

So I guess that such problems tell us less about the general
usefulness of programming languages than those would like us to
believe who promote a programming language by showing that it works
nicely for such problems.

- anton
-- 
M. Anton Ertl  http://www.complang.tuwien.ac.at/anton/home.html
comp.lang.forth FAQs: http://www.complang.tuwien.ac.at/forth/faq/toc.html
     New standard: http://www.forth200x.org/forth200x.html
   EuroForth 2013: http://www.euroforth.org/ef13/

[toc] | [prev] | [standalone]

Page 3 of 3 — ← Prev page 1 2 [3]

Back to top | Article view | comp.lang.forth

csiph-web