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

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

Bitonic sort

Started byHans Bezemer <the.beez.speaks@gmail.com>
First post2014-04-10 12:55 +0200
Last post2014-04-12 12:35 -0700
Articles 6 on this page of 26 — 9 participants

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

Contents

  Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-10 12:55 +0200
    Re: Bitonic sort mhx@iae.nl - 2014-04-10 12:39 -0700
      Re: Bitonic sort Melzzzzz <mel@zzzzz.com> - 2014-04-12 14:08 +0200
        Re: Bitonic sort mhx@iae.nl - 2014-04-12 05:42 -0700
          Re: Bitonic sort Melzzzzz <mel@zzzzz.com> - 2014-04-12 19:02 +0200
            Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-12 19:43 +0200
              Re: Bitonic sort Melzzzzz <mel@zzzzz.invalid> - 2014-04-12 20:16 +0200
                Re: Bitonic sort mhx@iae.nl - 2014-04-12 11:54 -0700
                  Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-12 23:14 +0200
          Re: Bitonic sort "Rod Pemberton" <dont_use_email@xnothavet.cqm> - 2014-04-12 18:25 -0400
            Re: Bitonic sort anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2014-04-13 13:07 +0000
        Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-12 16:45 +0200
    Re: Bitonic sort "Rod Pemberton" <dont_use_email@xnothavet.cqm> - 2014-04-10 19:29 -0400
      Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-11 11:29 +0200
        Re: Bitonic sort albert@spenarnc.xs4all.nl (Albert van der Horst) - 2014-04-11 09:49 +0000
          Re: Bitonic sort m.a.m.hendrix@tue.nl - 2014-04-11 04:17 -0700
            Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-11 16:18 +0200
            Re: Bitonic sort albert@spenarnc.xs4all.nl (Albert van der Horst) - 2014-04-11 16:29 +0000
              Re: Bitonic sort anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2014-04-11 17:18 +0000
                Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-12 00:13 +0200
    Re: Bitonic sort humptydumpty <ouatubi@gmail.com> - 2014-04-11 03:28 -0700
      Re: Bitonic sort humptydumpty <ouatubi@gmail.com> - 2014-04-11 22:35 -0700
        Re: Bitonic sort mhx@iae.nl - 2014-04-12 02:30 -0700
          Re: Bitonic sort humptydumpty <ouatubi@gmail.com> - 2014-04-12 04:09 -0700
          Re: Bitonic sort Hans Bezemer <the.beez.speaks@gmail.com> - 2014-04-12 14:16 +0200
            Re: Bitonic sort humptydumpty <ouatubi@gmail.com> - 2014-04-12 12:35 -0700

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

#29522

Fromhumptydumpty <ouatubi@gmail.com>
Date2014-04-11 03:28 -0700
Message-ID<3b17b57e-0ccd-4bd5-9e9d-dae4c48f8ecd@googlegroups.com>
In reply to#29505
On Thursday, April 10, 2014 1:55:59 PM UTC+3, The Beez wrote:
> L.s.
> 
> 
> 
> I guess this is the first implementation of a bitonic sort in Forth. Usually
> 
> this algorithm is implemented parallel, but this one works fine on a
> 
> non-parallel system. Second, bitonic sorts require a number of elements
> 
> that is equal to a power of two - this can sort arrays of any size.
> 
> 
> 
> It's faster than the Mergesorts I've seen here, but slower than your average
> 
> Shellsort, Heapsort or Quicksort. This implementation does quite a bit of
> 
> stack trashing - but uses no locals. The EXIT instead of the ELSE you might
> 
> expect is due to the tail call optimizer of 4tH.
> 
> 
> 
> It's compatible with Wil Baden's QSORT.
> 
> 
> 
> Hans Bezemer
> 
> 
> 
> ---8<---
> 
> [UNDEFINED] precedes [IF]
> 
> defer precedes                         ( addr addr -- flag )
> 
> [THEN]                                 \ compatible with QSORT
> 
> 
> 
> : (bitonicMerge)                       ( a n f)
> 
>   over 1 > if
> 
>     over 1 begin over over > while 1 lshift repeat nip 1 rshift
> 
>     rot over - >r rot r> swap          ( f m n-m a)
> 
>     over cells over + over 2>r 2swap 2r>
> 
>     ?do                                ( n-m a f m)
> 
>        over over cells i + i           ( n-m a f m f i+m i)
> 
>        rot >r over @ over @ precedes r> =
> 
>        if over @ over @ swap rot ! swap ! else drop drop then
> 
>     1 cells +loop                      ( n-m a f m)
> 
>     >r over over r@ swap recurse       ( n-m a f R: m)
> 
>     r> cells rot + -rot recurse exit   ( a+m n-m f )
> 
>   then
> 
>   drop drop drop
> 
> ;
> 
> 
> 
> : (bitonicSort)                        ( a n f)
> 
>   over 1 > if
> 
>     >r over over 2/ r@ 0= recurse      ( a n R: f)
> 
>     over over 2/ cells + over dup 2/ - r@ recurse
> 
>     r> (bitonicMerge) exit
> 
>   then
> 
>   drop drop drop
> 
> ;
> 
> 
> 
> : sort true (bitonicSort) ;            ( a n --)
> 
> ---8<---

Hi!

Here a little more factored version:


[UNDEFINED] precedes [IF]
defer precedes                         ( addr addr -- flag )
[THEN]                                 \ compatible with QSORT

[UNDEFINED] 3dup [IF]
: 3dup	2 pick 2 pick 2 pick ;
[THEN]

: 2^log2		( n -- 2^log2	; return greatest power-of-2 less than N )
	1
	BEGIN	( n 2^m )
		2dup >
	WHILE
		1 lshift
	REPEAT
	nip 1 rshift
;
: exchange		( a1 a2 --	; exchange values from addresses A1 and A2 )
	over @ over @
	swap rot !
	swap !
;
: -invalid		( a n f --	; for inappropriately size, exit immediately from caller )
	over 2 < IF drop 2drop rdrop THEN
;
: (bitonicMerge)	( a n f )
	-invalid
	>R dup 2^log2 >R		( a n  R: f m )
	R@ - swap 2dup swap 		( r a a r  R: f m )
	cells bounds R> R> 2swap	( r a m f a+r*cells a )
	?DO    	( r a m f )
		2dup swap cells i + i rot >R	( r a m f f i+m*cells i  R: f )
		over @ over @ precedes R> =	( r a m f i+m*cells i f' )
		IF	( r a m f i+m i )
			exchange
		ELSE
			2drop
		THEN
	[ 1 cells ] literal
	+LOOP           		( r a m f )
	3dup	RECURSE
	>R cells + swap R>		( a+m*cells r f )
		RECURSE
;
: (bitonicSort)		( a n f )
	-invalid
	>R
	2dup 2/ R@ 0= RECURSE      ( a n  R: f )
	2dup 2/ cells + over dup 2/ - R@ RECURSE
	R> (bitonicMerge)
;
: sort true (bitonicSort) ;            ( a n -- )


Have a nice day,
humptydumpty

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

#29553

Fromhumptydumpty <ouatubi@gmail.com>
Date2014-04-11 22:35 -0700
Message-ID<2747cc59-e62e-437d-8627-958948c82d8b@googlegroups.com>
In reply to#29522
Most of stack juggling vanishes if we observe that flag f remain unchanged throughout forth-words - making it a ideal candidate for a 'variable'.

Humptydumpty.

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

#29557

Frommhx@iae.nl
Date2014-04-12 02:30 -0700
Message-ID<2809ef62-4f5a-4808-ade0-00ba1770527d@googlegroups.com>
In reply to#29553
On Saturday, April 12, 2014 7:35:07 AM UTC+2, humptydumpty wrote:
> Most of stack juggling vanishes if we observe that flag f remain 
> unchanged throughout forth-words - making it a ideal candidate 
> for a 'variable'.

Did you try this? I think you forgot the effect of 
'f 0=' before the recursive call :-)

-marcel

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

#29561

Fromhumptydumpty <ouatubi@gmail.com>
Date2014-04-12 04:09 -0700
Message-ID<e1a55813-8552-4e89-adc7-3ab2abd02ee6@googlegroups.com>
In reply to#29557
On Saturday, April 12, 2014 12:30:52 PM UTC+3, m...@iae.nl wrote:
> On Saturday, April 12, 2014 7:35:07 AM UTC+2, humptydumpty wrote:
> 
> > Most of stack juggling vanishes if we observe that flag f remain 
> 
> > unchanged throughout forth-words - making it a ideal candidate 
> 
> > for a 'variable'.
> 
> 
> 
> Did you try this? I think you forgot the effect of 
> 
> 'f 0=' before the recursive call :-)
> 
> 
> 
> -marcel

Hi!
Not tried (for sure :-).
Only looked over in speed motion (on smartphone).
Shame on me, there is 'r@ 0= recurse' on (bitonicsort).
Evil was made, what could I do now? :-)

Thanks and have a nice day,
humptydumpty

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

#29565

FromHans Bezemer <the.beez.speaks@gmail.com>
Date2014-04-12 14:16 +0200
Message-ID<53492e66$0$2966$e4fe514c@news2.news.xs4all.nl>
In reply to#29557
mhx@iae.nl wrote:

> On Saturday, April 12, 2014 7:35:07 AM UTC+2, humptydumpty wrote:
>> Most of stack juggling vanishes if we observe that flag f remain
>> unchanged throughout forth-words - making it a ideal candidate
>> for a 'variable'.
> 
> Did you try this? I think you forgot the effect of
> 'f 0=' before the recursive call :-)
No, it won't do. While debugging the routine I observed its behavior. Yes,
throughout the call it stays constant - but not beyond, so that only a
local would do ;-)

If it were really constant I doubt it would have any real use at all.

Hans Bezemer

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

#29585

Fromhumptydumpty <ouatubi@gmail.com>
Date2014-04-12 12:35 -0700
Message-ID<1eb6e135-8967-4595-bc8f-da167288112a@googlegroups.com>
In reply to#29565
On Saturday, April 12, 2014 3:16:05 PM UTC+3, The Beez wrote:
> Marcel wrote:
> 
> 
> 
> > On Saturday, April 12, 2014 7:35:07 AM UTC+2, humptydumpty wrote:
> 
> >> Most of stack juggling vanishes if we observe that flag f remain
> 
> >> unchanged throughout forth-words - making it a ideal candidate
> 
> >> for a 'variable'.
> 
> > 
> 
> > Did you try this? I think you forgot the effect of
> 
> > 'f 0=' before the recursive call :-)
> 
> No, it won't do. While debugging the routine I observed its behavior. Yes,
> 
> throughout the call it stays constant - but not beyond, so that only a
> 
> local would do ;-)
> 
> 
> 
> If it were really constant I doubt it would have any real use at all.
> 
> 
> 
> Hans Bezemer

Hi!

My observation is not a totally nonsense.

(bitonicMerge) does not change at all flag through recursive call.
So, in (bitonicSort) I save flag into a variable, then fetch
flag value in (bitonicMerge).  Of course, stack juggling 
is visible reduced.

I'll post a tested version for Gforth:


 [UNDEFINED] precedes [IF]
defer precedes                         ( addr addr -- flag )
[THEN]                                 \ compatible with QSORT

: 2^log2                ( n -- 2^log2        ; return greatest power-of-2 less than N )
        1
        BEGIN        ( n 2^ )
                2dup >
        WHILE
                1 lshift
        REPEAT
        nip 1 rshift
;
: exchange                ( a1 a2 --        ; exchange values from addresses A1 and A2 )
        over @ over @
        swap rot !
        swap !
;
        VARIABLE Flag
: (bitonicMerge)        ( a n )
        dup 2 < IF 2drop EXIT THEN
        swap >R dup 2^log2 tuck - >R    ( m  R: a r )
        2R@ swap rot 2R>                ( r a m a r )
        cells bounds
        ?DO     ( r a m )
                dup cells i + i         ( r a m i+m*cells i )
                over @ over @ precedes Flag @ =
                IF      ( r a m i+m*cells i )
                        exchange
                ELSE
                        2drop
                THEN
        [ 1 cells ] literal
        +LOOP
        2dup    RECURSE         ( r a m )
        cells + swap            ( a+m*cells r )
                RECURSE
;
: (bitonicSort)                ( a n f )
        over 2 < IF drop 2drop EXIT THEN
        >R
        2dup 2/ R@ 0= RECURSE      ( a n  R: f )
        2dup 2/ cells + over dup 2/ - R@ RECURSE
        R> Flag ! (bitonicMerge)
;
: sort true (bitonicSort) ;     ( a n -- )


If really cost of calls is too big, we can use
macro versions for 'exchange' and '2^log2'.

Have a nice time,
humptydumpty

[toc] | [prev] | [standalone]

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

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

csiph-web