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

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

Rosetta Code: Top rank per group

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

Contents

  Rosetta Code: Top rank per group Julian Fondren <julian.fondren@gmail.com> - 2014-02-12 17:37 -0800
    Re: Rosetta Code: Top rank per group "Rod Pemberton" <dont_use_email@xnohavenotit.cnm> - 2014-02-13 03:58 -0500
      Re: Rosetta Code: Top rank per group Hans Bezemer <the.beez.speaks@gmail.com> - 2014-02-13 19:11 +0100
        Re: Rosetta Code: Top rank per group Julian Fondren <julian.fondren@gmail.com> - 2014-02-13 12:08 -0800
          Re: Rosetta Code: Top rank per group Hans Bezemer <the.beez.speaks@gmail.com> - 2014-02-14 10:57 +0100
            Re: Rosetta Code: Top rank per group Paul Rubin <no.email@nospam.invalid> - 2014-02-14 02:50 -0800
            Jensen's device (was: Rosetta Code: ...) anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2014-02-14 11:48 +0000
              Re: Jensen's device (was: Rosetta Code: ...) Hans Bezemer <the.beez.speaks@gmail.com> - 2014-02-14 16:46 +0100
                Re: Jensen's device (was: Rosetta Code: ...) "Rod Pemberton" <dont_use_email@xnohavenotit.cnm> - 2014-02-14 11:30 -0500
                  Re: Jensen's device (was: Rosetta Code: ...) Hans Bezemer <the.beez.speaks@gmail.com> - 2014-02-14 23:35 +0100
                Re: Jensen's device (was: Rosetta Code: ...) anton@mips.complang.tuwien.ac.at (Anton Ertl) - 2014-02-15 13:36 +0000
              Re: Jensen's device (was: Rosetta Code: ...) albert@spenarnc.xs4all.nl (Albert van der Horst) - 2014-02-14 19:12 +0000
              Re: Jensen's device (was: Rosetta Code: ...) mhx@iae.nl - 2014-02-14 12:13 -0800
                Re: Jensen's device (was: Rosetta Code: ...) Hans Bezemer <the.beez.speaks@gmail.com> - 2014-02-14 23:47 +0100
                Re: Jensen's device (was: Rosetta Code: ...) mhx@iae.nl - 2014-02-14 23:45 -0800
                  Re: Jensen's device (was: Rosetta Code: ...) mhx@iae.nl - 2014-02-15 02:49 -0800
                    Re: Jensen's device (was: Rosetta Code: ...) albert@spenarnc.xs4all.nl (Albert van der Horst) - 2014-02-15 11:54 +0000
        Re: Rosetta Code: Top rank per group Hans Bezemer <the.beez.speaks@gmail.com> - 2014-02-13 23:20 +0100
    Re: Rosetta Code: Top rank per group Andrew Haley <andrew29@littlepinkcloud.invalid> - 2014-02-13 04:11 -0600
    Re: Rosetta Code: Top rank per group humptydumpty <ouatubi@gmail.com> - 2014-02-13 10:48 -0800
      Re: Rosetta Code: Top rank per group humptydumpty <ouatubi@gmail.com> - 2014-02-13 20:23 -0800

Page 1 of 2  [1] 2  Next page →

#28348 — Rosetta Code: Top rank per group

Hello clf,

Rosetta Code has a 'top rank per group' task:
http://rosettacode.org/wiki/Top_rank_per_group

Which reads:

---
Find the top N salaries in each department, where N is provided as a parameter.
Use this data as a formatted internal data structure (adapt it to your
language-native idioms, rather than parse at runtime), or identify your
external data source:

Employee Name,Employee ID,Salary,Department
Tyler Bennett,E10297,32000,D101
John Rappl,E21437,47000,D050
George Woltman,E00127,53500,D101
Adam Smith,E63535,18000,D202
Claire Buckman,E39876,27800,D202
David McClellan,E04242,41500,D101
Rich Holcomb,E01234,49500,D202
Nathan Adams,E41298,21900,D050
Richard Potter,E43128,15900,D101
David Motsinger,E27002,19250,D202
Tim Sampair,E03033,27000,D101
Kim Arlich,E10001,57000,D190
Timothy Grove,E16398,29900,D190
---

If you look on the page you'll note that there is no Forth solution.

In general, I think there are three good kinds of solutions to this problem,
with the best depending on your circumstances.  They are:

1. brute-force the answer with high-level data structures: walk the table,
adding departments as keys to a hash table, the values of which are lists of
salaries.  Once you've exhausted the table, sort the keys of the hash (for nice
output) and then print them and their top N of the sorted lists of salaries.

(If you've never used a Perl oneliner that you wrote in a minute to chew on
multiple repquota streams and spit out the top diskspace-using users, then that
I call this a 'good solution' may puzzle you.)

2. feed this table to a relational DBMS and then use SQL to get the answer.

3. partially reinvent relational databases.  Even if the most advanced text
that you've read is The Manga Guide to Databases, it'll immediately strike you
that the table above may look nice, but... if you split it up and rearrange it
a bit *like so*, it can be much easier to work with...

There is also, no pun intended and nothing meant by it, a fourth solution:
solve the problem with custom data types and algorithms that are closely
dependent on both the exact query and the exact data.

I'd like to demonstrate a solution of this last kind.

First, an uninteresting representation of the employee table: a solid mass of
counted strings.

: string, ( c-addr u -- )
  dup c,  here swap  dup allot  move ;

variable #employees
: | ( -- )
  1 #employees +!
  begin [char] , parse dup while string, repeat 2drop ;

create employees
\ Employee Name,Employee ID,Salary,Department
| Tyler Bennett,E10297,32000,D101
| John Rappl,E21437,47000,D050
| George Woltman,E00127,53500,D101
| Adam Smith,E63535,18000,D202
| Claire Buckman,E39876,27800,D202
| David McClellan,E04242,41500,D101
| Rich Holcomb,E01234,49500,D202
| Nathan Adams,E41298,21900,D050
| Richard Potter,E43128,15900,D101
| David Motsinger,E27002,19250,D202
| Tim Sampair,E03033,27000,D101
| Kim Arlich,E10001,57000,D190
| Timothy Grove,E16398,29900,D190

4 constant #columns

: .employee ( a -- )
  cr #columns 1 do count 2dup type ." , " + loop count type ;

: /employee ( a -- a' )
  #columns 0 do count + loop ;

: salary ( a -- n )
  count + count + count 0. 2swap >number 2drop d>s ;

: department ( a -- n )
  count + count + count + count 0. 2swap 1 /string >NUMBER 2drop d>s ;

: .employees ( -- )
  employees  #employees @ 0 do dup .employee /employee loop drop ;

Second, an always-sorted 'top N' type:

( top-N array : {max,cur,x*cur} )
: topn ( n -- a )
  dup 2 + cells  dup allocate throw tuck swap erase
  tuck ! 0 over cell+ ! ;

: >topn ( n a -- )
  dup 2@ <> if 1 over cell+ +! then
  dup 2 cells + swap  cell+ @ cells bounds do
    dup i @ > if i @ swap i ! then
  cell +loop drop ;

: .topn ( a -- )
  cell+ dup cell+ swap @ cells bounds ?do i @ . cell +loop ;

Third, since the departments are numerical and with a small range, and again so
that I don't have to *sort* anything, an array of potential departments with
their values either 0 or a TOPN, and then the final words.

( query )
variable max-n

300 constant #departments
create departments  #departments cells allot

: >department ( n-salary n-department -- )
  cells departments + dup @ if @ >topn
  else max-n @ topn tuck swap ! >topn then ;

: query ( -- ) \ top N salaries by department
  departments #departments cells erase
  employees #employees @ 0 do
    dup salary over department >department
  /employee loop drop ;

: .top-salaries ( -- )
  #departments 0 do
    i cells departments + @
    dup if cr ." D" i 0 .r space .topn else drop
  then loop ;

: top-salaries ( n -- )
  max-n ! query .top-salaries ;

And that's it.  No questions about any of that?  OK.  With user input indented and with extra spacing:

  3 top-salaries
D50 47000 21900
D101 53500 41500 32000
D190 57000 29900
D202 49500 27800 19250  ok

  1 top-salaries
D50 47000
D101 53500
D190 57000
D202 49500  ok

  400 top-salaries
D50 47000 21900
D101 53500 41500 32000 27000 15900
D190 57000 29900
D202 49500 27800 19250 18000  ok

Although the query is 'top *salaries* by department', now that I look at the
other answers on that page, I see that every one of them provides the employee
record associated with the top salaries.  For that, TOPN could have pairs of
(salary,employee record address) cells.

I haven't submitted this as an answer to the 'Top rank per group' task on
Rosetta Code; I'm more tempted to provide a brute-force-with-high-level-data-structures answer.  I'd like to see how you would answer this task.


-- Julian

[toc] | [next] | [standalone]

#28366

On Wed, 12 Feb 2014 20:37:15 -0500, Julian Fondren  
<julian.fondren@gmail.com> wrote:

> Rosetta Code has a 'top rank per group' task:
> http://rosettacode.org/wiki/Top_rank_per_group
>
> [snip]

Forth examples are not available for many of the
Rosetta Code tasks.

Why is this one of interest to you?

Most notably, Forth is not even on the
*metaprogramming* page:

http://rosettacode.org/wiki/Metaprogramming

Sad...

It's not on many, many others too:

http://rosettacode.org/wiki/Parsing/RPN_to_infix_conversion
http://rosettacode.org/wiki/Create_an_HTML_table
http://rosettacode.org/wiki/ABC_Problem
http://rosettacode.org/wiki/Remove_lines_from_a_file
...


Rod Pemberton

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

#28387

Rod Pemberton wrote:

> On Wed, 12 Feb 2014 20:37:15 -0500, Julian Fondren
> Forth examples are not available for many of the
> Rosetta Code tasks.
> Why is this one of interest to you?
I dunno, but I've solved quite a few - I don't always publish them. This is
the task at hand (in 4tH):

---8<---
include lib/shelsort.4th               \ for SORT
include lib/compare.4th                \ for COMPARE

4 constant #fields                     \ number of fields

0 +constant .name                      \ name the fields
1 +constant .id                        \ not all of these
2 +constant .salary                    \ are really required
3 +constant .dept                      \ for this program

create employees                       \ create the table
\ Employee Name,Employee ID,Salary,Department
  ," Tyler Bennett"   ," E10297" 32000 , ," D101"
  ," John Rappl"      ," E21437" 47000 , ," D050"
  ," George Woltman"  ," E00127" 53500 , ," D101"
  ," Adam Smith"      ," E63535" 18000 , ," D202"
  ," Claire Buckman"  ," E39876" 27800 , ," D202"
  ," David McClellan" ," E04242" 41500 , ," D101"
  ," Rich Holcomb"    ," E01234" 49500 , ," D202"
  ," Nathan Adams"    ," E41298" 21900 , ," D050"
  ," Richard Potter"  ," E43128" 15900 , ," D101"
  ," David Motsinger" ," E27002" 19250 , ," D202"
  ," Tim Sampair"     ," E03033" 27000 , ," D101"
  ," Kim Arlich"      ," E10001" 57000 , ," D190"
  ," Timothy Grove"   ," E16398" 29900 , ," D190"
  here employees - #fields / constant #emp
                                       \ calculate the number of employees
#emp array emp-idx                     \ create an index
emp-idx #emp th equates emp-idx-end    \ pointer to end of index
                                       ( x n --)
: init-idx 0 do employees i #fields * + over i th ! loop drop ;
                                       \ sort on the department
: sort-on-department                   ( x n --)
  [: >r .dept @c count r> .dept @c count compare 0< ;] is precedes sort
;
                                       \ sort on the salary
: sort-on-salary                       ( x1 x2 --)
  [: >r .salary @c r> .salary @c > ;] is precedes over - sort
;
                                       \ sort on both department and salary
: sort-on-sal/dept                     ( x n --)
  over over sort-on-department         \ first sort on department
  0 ?do                                \ go sequentially through index
    dup @ .dept @c count emp-idx i th @ .dept @c count compare
    if emp-idx i th dup >r sort-on-salary r> then
  loop emp-idx-end sort-on-salary      \ find department subsets
;                                      \ determine length and sort them
                                       \ display the salaries in a
department
: .salaries                            ( n x1 x2 -- n)
  over - rot dup >r min over @ .dept @c count type space
  bounds ?do i @ .salary @c . loop cr r>
;                                      \ no more than first n entries
                                       \ show the top n salaries/department
: top-salaries                         ( n --)
  emp-idx #emp 0 ?do                   \ go sequentially through index
    dup @ .dept @c count emp-idx i th @ .dept @c count compare
    if emp-idx i th dup >r .salaries r> then
  loop emp-idx-end .salaries drop      \ show salaries on department switch
;

emp-idx #emp init-idx                  \ first create the index
emp-idx #emp sort-on-sal/dept          \ now sort it

3 top-salaries cr                      \ first 2 salaries
1 top-salaries cr                      \ first salary
200 top-salaries cr                    \ first 200 salaries
---8<---


> 
> Most notably, Forth is not even on the
> *metaprogramming* page:
> 
> http://rosettacode.org/wiki/Metaprogramming
> 
> Sad...
> 
> It's not on many, many others too:

> http://rosettacode.org/wiki/ABC_Problem

Did that one too:

---8<---
offset (blocks)                        \ initial block data
  c" BO" c" XK" c" DQ" c" CP" c" NA"
  c" GT" c" RE" c" TG" c" QD" c" FS"
  c" JW" c" HU" c" VI" c" AN" c" OB"
  c" ER" c" FS" c" LY" c" PC" c" ZM"
  0 c, 0 c,                            \ terminate the blocks

21 constant #blocks                    \ number of blocks plus one
#blocks 2* buffer: blocks              \ allocate the blocks
defer get-letter                       \ defer comparison

: block@ dup c@ swap char+ c@ ;        ( x -- c1 c2)
: block! tuck c! char+ c! ;            ( c1 c2 x --)
: block+ 2 chars + ;                   ( x -- x+2)
: swap-blocks over over block@ 2>r block@ rot block! 2r> rot block! ;
                                       ( x1 x2 --)
: init-block                           ( --)
  #blocks 0 ?do i 2* (blocks) i 2* 1+ (blocks) blocks i 2* chars + block!
loop
;

: can-make-word                        ( a n x -- f)
  over if -rot get-letter else true then >r drop drop drop r>
;                                      \ if any string left then do the test
                                       \ otherwise we've done it
:noname                                ( x a n -- x a n f)
  >r >r dup                            \ store string on return stack
  begin                                \ are there no more blocks?
    dup c@                             \ if so exit
  while                                \ does the first or second letter
equal
    dup dup char+ r@ c@ bl invert and >r c@ r@ = swap c@ r> = or
    if                                 \ if so then swap the blocks
      over over swap-blocks            \ and try for the rest of the letters
      over r> r@ over >r chop rot block+ can-make-word >r
      over over swap-blocks            \ return to the previous state
      r@ if drop r> r> r> rot exit else r> drop then
    then                               \ exit if we found a solution
    block+                             \ if didn't work, try the next block
  repeat drop r> r> false              \ restore stack diagram, no more
blocks
; is get-letter                        \ but remember we failed

init-block

s" A"       2dup blocks can-make-word . type cr
s" BARK"    2dup blocks can-make-word . type cr
s" BOOK"    2dup blocks can-make-word . type cr
s" TREAT"   2dup blocks can-make-word . type cr
s" Common"  2dup blocks can-make-word . type cr
s" SQUAD"   2dup blocks can-make-word . type cr
s" Confuse" 2dup blocks can-make-word . type cr
---8<---

Others I find a bit too trivial - or too complex. I don't feel like doing a
lot of programming to produce an alterating series of A's and B's.

Hans Bezemer

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

#28390

On Thursday, February 13, 2014 2:58:22 AM UTC-6, Rod Pemberton wrote:
> Most notably, Forth is not even on the
> 
> *metaprogramming* page:
> 
> 
> 
> http://rosettacode.org/wiki/Metaprogramming
> 

It's a bad task for the site.  Forth is present on the 'extend your langauge'
task, 

http://rosettacode.org/wiki/Extend_your_language

Which asks for "a new flow control mechanism", with a four-way branch as a
specific suggestion:

: fb ( n -- )
  dup 5 mod 0=  over 3 mod 0=
  BOTH   ." FizzBuzz "
  ELSE   ." Fizz "
  ORELSE ." Buzz "
  ELSE   dup .
  NEITHER drop ;
: fizzbuzz ( n -- ) 0 do i 1+ fb loop ;

Rather than answer Metaprogramming, I'd rather there were new tasks like
'extend your language' that allowed Forth to demonstrate different kinds of
metaprogramming.

There are after all seemingly limitless mathematic tasks on the site, rather
than a single task that requests a demonstration of each language's total
capacity for mathematics.  And instead of an all-inclusive UI task, there are
tasks like Hello world/Graphical:

http://rosettacode.org/wiki/Hello_world/Graphical

For which this is currently the only Forth solution:

HWND z" Goodbye, World!" z" (title)" MB_OK MessageBox

...

On Thursday, February 13, 2014 12:11:18 PM UTC-6, The Beez wrote:
> Others I find a bit too trivial - or too complex. I don't feel like doing a
> 
> lot of programming to produce an alterating series of A's and B's.

Sure, but part of the point is that for some languages it's not a lot of
programming.  Another is in a language the task is more naturally accomplished
in a different way.  And then there incidental comparisons like your sorting
syntax:

: sort-on-salary ( x n --) 
  [: >r .salary @c r> .salary @c > ;] is precedes sort ; 

vs. the very similar Ada:

function Compare_Salary (Left, Right : Employee_Data) return Boolean is
begin
  return Left.Salary > Right.Salary;
end Compare_Salary;
package Salary_Sort is new Employee_Vectors.Generic_Sorting
  ("<" => Compare_Salary);
...
Salary_Sort.Sort (Example_Data);

The most striking solution for me is the SQL one, which I figured would be just
about no code at all, but which actually shows how breath-takingly tedious it
is to use *only SQL* to populate the table and to massage the query results
into nice human-readable output.


-- Julian

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

#28420

Julian Fondren wrote:

> Sure, but part of the point is that for some languages it's not a lot of
> programming.  Another is in a language the task is more naturally
> accomplished
> in a different way.

Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth

I did it in two lines. Not even J is shorter. I also made an awesome Markov
engine, but it didn't quite fit the syntax required (hey, this is Forth is
it?) so I never posted it. Still, it can easily do stuff like this:

# BNF Syntax testing rules
rules
"A" -> "apple"
"WWWW" -> "with"
"Bgage" -> "->.*"
"B" -> "bag"
"->.*" -> "money"
"W" -> "WW"
"S" -> ."shop"
"T" -> "the"
"the shop" -> "my brother"
"a never used" -> ."terminating rule"

= I bought a B of As W my Bgage from T S.

Hans Bezemer

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

#28421

Hans Bezemer <the.beez.speaks@gmail.com> writes:
> Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
> I did it in two lines. Not even J is shorter. 

I don't think the Forth solution actually does what was asked in the
problem.  I think it can be done in Forth but it would be messy.

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

#28425 — Jensen's device (was: Rosetta Code: ...)

Hans Bezemer <the.beez.speaks@gmail.com> writes:
>Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
>
>I did it in two lines.

These lines are:

: sum 0 s>f 1+ swap ?do i over execute f+ loop drop ;
:noname s>f 1 s>f fswap f/ ; 1 100 sum f.

Whereas the core of the original is:

print (sum (i, 1, 100, 1/i))

where the parameters are passed by name.

However, you pass i to the :noname definition on the stack, not by
name.  The following passes both i and 1/i as an xt:

fvariable ii \ I is a Forth word that we need
: sum ( xt1 lo hi xt2 -- r )
  0e swap 1+ rot ?do ( addr xt r1 )
    i s>f over execute f! dup execute f+
  loop 2drop ;
' ii 1 100 :noname 1e ii f@ f/ ; sum f.

I have added it to the Rosettacode page.

- 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] | [next] | [standalone]

#28428 — Re: Jensen's device (was: Rosetta Code: ...)

Anton Ertl wrote:

> Hans Bezemer <the.beez.speaks@gmail.com> writes:
>>Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
>>
>>I did it in two lines.
> 
> These lines are:
> 
> : sum 0 s>f 1+ swap ?do i over execute f+ loop drop ;
> :noname s>f 1 s>f fswap f/ ; 1 100 sum f.
> 
> Whereas the core of the original is:
> 
> print (sum (i, 1, 100, 1/i))
> 
> where the parameters are passed by name.
> 
> However, you pass i to the :noname definition on the stack, not by
> name.  The following passes both i and 1/i as an xt:
> 
> fvariable ii \ I is a Forth word that we need
> : sum ( xt1 lo hi xt2 -- r )
>   0e swap 1+ rot ?do ( addr xt r1 )
>     i s>f over execute f! dup execute f+
>   loop 2drop ;
> ' ii 1 100 :noname 1e ii f@ f/ ; sum f.
> 
> I have added it to the Rosettacode page.
I see the point of your argument, but note the idea of Rosetta code is: how
would you solve it in YOUR language. In this case no sane Forth programmer
would declare an extra variable - that's the whole idea of Forth. He would
pass it as an item on the stack. That's why.

Note that as a matter of fact, even C does not pass a NAME, it passes
pointers. Passing names is only possible is it is passed by *reference* -
something C obviously doesn't support.

That my solution can be classified as valid can be determined by what had
happend IF it had been passed by value: "If the last parameter to sum had
been passed by value, and assuming the initial value of i were 1, the
result would have been 100 × 1/1 = 100". 

Hans Bezemer

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

#28431 — Re: Jensen's device (was: Rosetta Code: ...)

On Fri, 14 Feb 2014 10:46:30 -0500, Hans Bezemer  
<the.beez.speaks@gmail.com> wrote:

> Note that as a matter of fact, even C does not pass a NAME,

That's true.  Very few languages support passing by name.
Take your pick: obscure, useless, obsolete, ill-conceived.

> [C] passes pointers.

It can.  That's called: pass by reference.
However, by default, C passes by value.

Argumentatively, passing by value is one of C's design flaws.
PL/I passes by reference by default which makes it easier
to pass parameters.  Passing by value is not needed that much.
IIRC, Kernighan and Ritchie debated over the best method to
pass parameters.

> Passing names is only possible [if] it is passed by *reference* -
> something C obviously doesn't support.

Sorry, but I think it's clear that you're confused...


Rod Pemberton

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

#28442 — Re: Jensen's device (was: Rosetta Code: ...)

Rod Pemberton wrote:

> On Fri, 14 Feb 2014 10:46:30 -0500, Hans Bezemer
> <the.beez.speaks@gmail.com> wrote:
> 
>> Note that as a matter of fact, even C does not pass a NAME,
> 
> That's true.  Very few languages support passing by name.
> Take your pick: obscure, useless, obsolete, ill-conceived.
> 
>> [C] passes pointers.
> 
> It can.  That's called: pass by reference.
> However, by default, C passes by value.
Well, how it was explained to me (a very long time ago) is that you manually
convert the variable to a "value" (a numerical address) which is passed -
hence ONLY passing by value (where C is concerned). The compiler itself
does no fancy tricks - you get what you asked for and you'll have to do it
yourself if you want it.

It worked for me, e.g. I found pointers in C much easier to understand than
their equivalents in Pascal. Programming languages that tried to be smarter
than me never worked very well for me anyway - hence Forth.

Since I have to delve into literature I haven't looked at for the last 30
years, I assume you're right and leave it at that. I think the issue is
academical at best.

But there still is a difference though between "passing by reference"
and "passing by name" - the latter as dead as a dodo, though.

Hans Bezemer

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

#28448 — Re: Jensen's device (was: Rosetta Code: ...)

Hans Bezemer <the.beez.speaks@gmail.com> writes:
>Anton Ertl wrote:
>
>> Hans Bezemer <the.beez.speaks@gmail.com> writes:
>>>Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
>>>
>>>I did it in two lines.
>> 
>> These lines are:
>> 
>> : sum 0 s>f 1+ swap ?do i over execute f+ loop drop ;
>> :noname s>f 1 s>f fswap f/ ; 1 100 sum f.
>> 
>> Whereas the core of the original is:
>> 
>> print (sum (i, 1, 100, 1/i))
>> 
>> where the parameters are passed by name.
>> 
>> However, you pass i to the :noname definition on the stack, not by
>> name.  The following passes both i and 1/i as an xt:
>> 
>> fvariable ii \ I is a Forth word that we need
>> : sum ( xt1 lo hi xt2 -- r )
>>   0e swap 1+ rot ?do ( addr xt r1 )
>>     i s>f over execute f! dup execute f+
>>   loop 2drop ;
>> ' ii 1 100 :noname 1e ii f@ f/ ; sum f.
>> 
>> I have added it to the Rosettacode page.
>I see the point of your argument, but note the idea of Rosetta code is: how
>would you solve it in YOUR language.

It seems to me that the general Rosetta code idea is at odds with the
idea of the "Jensen's device" task then.  The example is called
"Jensen's device", not "the 100th harmonic number", and the task
description says: "This task is an exercise in call by name.".  Now it
seems to me that, for languages that don't have call-by-name, the task
is to do something that is relatively close to call-by-name, and
that's what I did.

If the task was just "the 100th harmonic number", the Forth solution
(following Chuck Moore's philosophy) is

.( 5.1873775...)

- 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] | [next] | [standalone]

#28432 — Re: Jensen's device (was: Rosetta Code: ...)

In article <2014Feb14.124846@mips.complang.tuwien.ac.at>,
Anton Ertl <anton@mips.complang.tuwien.ac.at> wrote:
>Hans Bezemer <the.beez.speaks@gmail.com> writes:
>>Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
>>
>>I did it in two lines.
>
>These lines are:
>
>: sum 0 s>f 1+ swap ?do i over execute f+ loop drop ;
>:noname s>f 1 s>f fswap f/ ; 1 100 sum f.
>
>Whereas the core of the original is:
>
>print (sum (i, 1, 100, 1/i))
>
>where the parameters are passed by name.
>
>However, you pass i to the :noname definition on the stack, not by
>name.  The following passes both i and 1/i as an xt:
>
>fvariable ii \ I is a Forth word that we need
>: sum ( xt1 lo hi xt2 -- r )
>  0e swap 1+ rot ?do ( addr xt r1 )
>    i s>f over execute f! dup execute f+
>  loop 2drop ;
>' ii 1 100 :noname 1e ii f@ f/ ; sum f.
>
>I have added it to the Rosettacode page.

It proves that one can do anything in Forth, but to me
Jensen's device should have been dead and buried
A.D. 1970. It is a mini-closure made possible by a
design error in algol 60 (not repeated in algol 68).

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

#28436 — Re: Jensen's device (was: Rosetta Code: ...)

On Friday, February 14, 2014 12:48:46 PM UTC+1, Anton Ertl wrote:
> Hans Bezemer <the.beez.speaks@gmail.com> writes:
> 
> >Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
> >
> >I did it in two lines. 
> These lines are:
> 
> : sum 0 s>f 1+ swap ?do i over execute f+ loop drop ; 
> :noname s>f 1 s>f fswap f/ ; 1 100 sum f.
> 
Which is IMHO a clear violation of the intent of JD. 

> Whereas the core of the original is:
>
> print (sum (i, 1, 100, 1/i))
>
> where the parameters are passed by name.
> 
> However, you pass i to the :noname definition on the stack, not by
> name.  The following passes both i and 1/i as an xt:
> 
> fvariable ii \ I is a Forth word that we need
> : sum ( xt1 lo hi xt2 -- r )
>   0e swap 1+ rot ?do ( addr xt r1 )
>     i s>f over execute f! dup execute f+
>   loop 2drop ;
> ' ii 1 100 :noname 1e ii f@ f/ ; sum f.
> 
> I have added it to the Rosettacode page.

: sum ( h l str -- ) ( F: -- r ) dlocal term 0e ?DO  I term evaluate F+  LOOP ;
: JD ( -- ) #101 1  S" s>f 1/f " sum F. ;
FORTH> JD 5.187378  ok  ( the correct answer )

-marcel

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

#28443 — Re: Jensen's device (was: Rosetta Code: ...)

mhx@iae.nl wrote:

> On Friday, February 14, 2014 12:48:46 PM UTC+1, Anton Ertl wrote:
>> Hans Bezemer <the.beez.speaks@gmail.com> writes:
>> 
>> >Take a look at http://rosettacode.org/wiki/Jensen%27s_Device#Forth
>> >
>> >I did it in two lines.
>> These lines are:
>> 
>> : sum 0 s>f 1+ swap ?do i over execute f+ loop drop ;
>> :noname s>f 1 s>f fswap f/ ; 1 100 sum f.
>> 
> Which is IMHO a clear violation of the intent of JD.
The intent of JD was "call by name". However, most of the examples in RC use
a local variable or "call by reference". That would defeat almost all
implementations in my book.

IMHO using the stack for "local variable" is as much a violation as the
local variable itself - or the address of a global for that matter.

Hans Bezemer

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

#28445 — Re: Jensen's device (was: Rosetta Code: ...)

On Friday, February 14, 2014 9:13:14 PM UTC+1, m...@iae.nl wrote:
[..]
> : sum ( h l str -- ) ( F: -- r ) dlocal term 0e ?DO  I term evaluate F+  LOOP ;
> : JD ( -- ) #101 1  S" s>f 1/f " sum F. ;
 
: 1/i  ]] I S>F 1/F [[ ; immediate
: sum ( h l -- ) ( F: -- r ) 0e ?DO  1/i F+  LOOP ;
: JD ( -- ) #101 1 sum F. ;
FORTH> jd 5.187378  ok

-marcel

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

#28446 — Re: Jensen's device (was: Rosetta Code: ...)

On Saturday, February 15, 2014 8:45:49 AM UTC+1, m...@iae.nl wrote:
> On Friday, February 14, 2014 9:13:14 PM UTC+1, m...@iae.nl wrote:
[..]
: sum ( u l 'i-xt a-xt -- ) ( F: -- r ) 
	LOCAL action  EXECUTE LOCAL 'i  
	'i !  0e 
	BEGIN  'i @ OVER <= 
	WHILE  action EXECUTE  F+  
	       1 'i +!
	REPEAT DROP ;
: JD  ( -- ) #100 1 [: HERE ;] [: HERE @ S>F 1/F ;]  sum F. ;

-marcel

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

#28447 — Re: Jensen's device (was: Rosetta Code: ...)

In article <8564425d-78e5-4518-9a4b-8dce01f71c3c@googlegroups.com>,
 <mhx@iae.nl> wrote:
>On Saturday, February 15, 2014 8:45:49 AM UTC+1, m...@iae.nl wrote:
>> On Friday, February 14, 2014 9:13:14 PM UTC+1, m...@iae.nl wrote:
>[..]
>: sum ( u l 'i-xt a-xt -- ) ( F: -- r )
>       LOCAL action  EXECUTE LOCAL 'i
>       'i !  0e
>       BEGIN  'i @ OVER <=
>       WHILE  action EXECUTE  F+
>              1 'i +!
>       REPEAT DROP ;
>: JD  ( -- ) #100 1 [: HERE ;] [: HERE @ S>F 1/F ;]  sum F. ;

You should probably use PAD instead of HERE.

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

#28392

Hans Bezemer wrote:

This one is shorter and more efficient - creates index in one go:

---8<---
include lib/shelsort.4th               \ for SORT
include lib/compare.4th                \ for COMPARE

4 constant #fields                     \ number of fields

2 +constant .salary                    \ offsets to the fields
3 +constant .dept                      \ in the employees table

create employees                       \ create the table
\ Employee Name,Employee ID,Salary,Department
  ," Tyler Bennett"   ," E10297" 32000 , ," D101"
  ," John Rappl"      ," E21437" 47000 , ," D050"
  ," George Woltman"  ," E00127" 53500 , ," D101"
  ," Adam Smith"      ," E63535" 18000 , ," D202"
  ," Claire Buckman"  ," E39876" 27800 , ," D202"
  ," David McClellan" ," E04242" 41500 , ," D101"
  ," Rich Holcomb"    ," E01234" 49500 , ," D202"
  ," Nathan Adams"    ," E41298" 21900 , ," D050"
  ," Richard Potter"  ," E43128" 15900 , ," D101"
  ," David Motsinger" ," E27002" 19250 , ," D202"
  ," Tim Sampair"     ," E03033" 27000 , ," D101"
  ," Kim Arlich"      ," E10001" 57000 , ," D190"
  ," Timothy Grove"   ," E16398" 29900 , ," D190"
  here employees - #fields / constant #emp
                                       \ calculate the number of employees
#emp array emp-idx                     \ create an index
                                       \ sort on department, salary
:noname                                ( x1 x2 -- f)
  over over >r .dept @c count r> .dept @c count compare dup
  if nip nip 0< else drop >r .salary @c r> .salary @c > then
; is precedes
                                       ( x n --)
: init-idx tuck 0 do employees i #fields * + over i th ! loop swap sort ;
                                       \ display the salaries in a
department
: .salaries                            ( n x1 x2 -- n)
  over - rot dup >r min over @ .dept @c count type space
  bounds ?do i @ .salary @c . loop cr r>
;                                      \ no more than first n entries
                                       \ show the top n salaries/department
: top-salaries                         ( n --)
  emp-idx #emp 0 ?do                   \ go sequentially through index
    dup @ .dept @c count emp-idx i th @ .dept @c count compare
    if emp-idx i th dup >r .salaries r> then
  loop emp-idx #emp th .salaries drop  \ show salaries on department switch
;

emp-idx #emp init-idx                  \ first create the index

3 top-salaries cr                      \ first 2 salaries
1 top-salaries cr                      \ first salary
200 top-salaries cr                    \ first 200 salaries
---8<---

Hans Bezemer

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

#28374

Hi,

Julian Fondren <julian.fondren@gmail.com> wrote:
> 
> Rosetta Code has a 'top rank per group' task:
> http://rosettacode.org/wiki/Top_rank_per_group
> 
>  employees  #employees @ 0 do dup .employee /employee loop drop ;
> 
> Second, an always-sorted 'top N' type:
> 
> ( top-N array : {max,cur,x*cur} )
> : topn ( n -- a )
>  dup 2 + cells  dup allocate throw tuck swap erase
>  tuck ! 0 over cell+ ! ;
> 
> : >topn ( n a -- )
>  dup 2@ <> if 1 over cell+ +! then
>  dup 2 cells + swap  cell+ @ cells bounds do
>    dup i @ > if i @ swap i ! then
>  cell +loop drop ;

This is a bit ugly, and as a solution doesn't scale at all well:
you're bubble-sorting the top N salaries.

Andrew.

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

#28389

On Thursday, February 13, 2014 3:37:15 AM UTC+2, Julian Fondren wrote:
> Hello clf,
> 
> 
> 
> Rosetta Code has a 'top rank per group' task:
> 
> http://rosettacode.org/wiki/Top_rank_per_group
> 
> 
> 
> Which reads:
> 
> 
> 
> ---
> 
> Find the top N salaries in each department, where N is provided as a parameter.
> 
> Use this data as a formatted internal data structure (adapt it to your
> 
> language-native idioms, rather than parse at runtime), or identify your
> 
> external data source:
> 
> 
> 
> Employee Name,Employee ID,Salary,Department
> 
> Tyler Bennett,E10297,32000,D101
> 
> John Rappl,E21437,47000,D050
> 
> George Woltman,E00127,53500,D101
> 
> Adam Smith,E63535,18000,D202
> 
> Claire Buckman,E39876,27800,D202
> 
> David McClellan,E04242,41500,D101
> 
> Rich Holcomb,E01234,49500,D202
> 
> Nathan Adams,E41298,21900,D050
> 
> Richard Potter,E43128,15900,D101
> 
> David Motsinger,E27002,19250,D202
> 
> Tim Sampair,E03033,27000,D101
> 
> Kim Arlich,E10001,57000,D190
> 
> Timothy Grove,E16398,29900,D190
> 
> ---
> 
> 
> 
> If you look on the page you'll note that there is no Forth solution.
> 
> 
> 
> In general, I think there are three good kinds of solutions to this problem,
> 
> with the best depending on your circumstances.  They are:
> 
> 
> 
> 1. brute-force the answer with high-level data structures: walk the table,
> 
> adding departments as keys to a hash table, the values of which are lists of
> 
> salaries.  Once you've exhausted the table, sort the keys of the hash (for nice
> 
> output) and then print them and their top N of the sorted lists of salaries.
> 
> 
> 
> (If you've never used a Perl oneliner that you wrote in a minute to chew on
> 
> multiple repquota streams and spit out the top diskspace-using users, then that
> 
> I call this a 'good solution' may puzzle you.)
> 
> 
> 
> 2. feed this table to a relational DBMS and then use SQL to get the answer.
> 
> 
> 
> 3. partially reinvent relational databases.  Even if the most advanced text
> 
> that you've read is The Manga Guide to Databases, it'll immediately strike you
> 
> that the table above may look nice, but... if you split it up and rearrange it
> 
> a bit *like so*, it can be much easier to work with...
> 
> 
> 
> There is also, no pun intended and nothing meant by it, a fourth solution:
> 
> solve the problem with custom data types and algorithms that are closely
> 
> dependent on both the exact query and the exact data.
> 
> 
> 
> I'd like to demonstrate a solution of this last kind.
> 
> 
> 
> First, an uninteresting representation of the employee table: a solid mass of
> 
> counted strings.
> 
> 
> 
> : string, ( c-addr u -- )
> 
>   dup c,  here swap  dup allot  move ;
> 
> 
> 
> variable #employees
> 
> : | ( -- )
> 
>   1 #employees +!
> 
>   begin [char] , parse dup while string, repeat 2drop ;
> 
> 
> 
> create employees
> 
> \ Employee Name,Employee ID,Salary,Department
> 
> | Tyler Bennett,E10297,32000,D101
> 
> | John Rappl,E21437,47000,D050
> 
> | George Woltman,E00127,53500,D101
> 
> | Adam Smith,E63535,18000,D202
> 
> | Claire Buckman,E39876,27800,D202
> 
> | David McClellan,E04242,41500,D101
> 
> | Rich Holcomb,E01234,49500,D202
> 
> | Nathan Adams,E41298,21900,D050
> 
> | Richard Potter,E43128,15900,D101
> 
> | David Motsinger,E27002,19250,D202
> 
> | Tim Sampair,E03033,27000,D101
> 
> | Kim Arlich,E10001,57000,D190
> 
> | Timothy Grove,E16398,29900,D190
> 
> 
> 
> 4 constant #columns
> 
> 
> 
> : .employee ( a -- )
> 
>   cr #columns 1 do count 2dup type ." , " + loop count type ;
> 
> 
> 
> : /employee ( a -- a' )
> 
>   #columns 0 do count + loop ;
> 
> 
> 
> : salary ( a -- n )
> 
>   count + count + count 0. 2swap >number 2drop d>s ;
> 
> 
> 
> : department ( a -- n )
> 
>   count + count + count + count 0. 2swap 1 /string >NUMBER 2drop d>s ;
> 
> 
> 
> : .employees ( -- )
> 
>   employees  #employees @ 0 do dup .employee /employee loop drop ;
> 
> 
> 
> Second, an always-sorted 'top N' type:
> 
> 
> 
> ( top-N array : {max,cur,x*cur} )
> 
> : topn ( n -- a )
> 
>   dup 2 + cells  dup allocate throw tuck swap erase
> 
>   tuck ! 0 over cell+ ! ;
> 
> 
> 
> : >topn ( n a -- )
> 
>   dup 2@ <> if 1 over cell+ +! then
> 
>   dup 2 cells + swap  cell+ @ cells bounds do
> 
>     dup i @ > if i @ swap i ! then
> 
>   cell +loop drop ;
> 
> 
> 
> : .topn ( a -- )
> 
>   cell+ dup cell+ swap @ cells bounds ?do i @ . cell +loop ;
> 
> 
> 
> Third, since the departments are numerical and with a small range, and again so
> 
> that I don't have to *sort* anything, an array of potential departments with
> 
> their values either 0 or a TOPN, and then the final words.
> 
> 
> 
> ( query )
> 
> variable max-n
> 
> 
> 
> 300 constant #departments
> 
> create departments  #departments cells allot
> 
> 
> 
> : >department ( n-salary n-department -- )
> 
>   cells departments + dup @ if @ >topn
> 
>   else max-n @ topn tuck swap ! >topn then ;
> 
> 
> 
> : query ( -- ) \ top N salaries by department
> 
>   departments #departments cells erase
> 
>   employees #employees @ 0 do
> 
>     dup salary over department >department
> 
>   /employee loop drop ;
> 
> 
> 
> : .top-salaries ( -- )
> 
>   #departments 0 do
> 
>     i cells departments + @
> 
>     dup if cr ." D" i 0 .r space .topn else drop
> 
>   then loop ;
> 
> 
> 
> : top-salaries ( n -- )
> 
>   max-n ! query .top-salaries ;
> 
> 
> 
> And that's it.  No questions about any of that?  OK.  With user input indented and with extra spacing:
> 
> 
> 
>   3 top-salaries
> 
> D50 47000 21900
> 
> D101 53500 41500 32000
> 
> D190 57000 29900
> 
> D202 49500 27800 19250  ok
> 
> 
> 
>   1 top-salaries
> 
> D50 47000
> 
> D101 53500
> 
> D190 57000
> 
> D202 49500  ok
> 
> 
> 
>   400 top-salaries
> 
> D50 47000 21900
> 
> D101 53500 41500 32000 27000 15900
> 
> D190 57000 29900
> 
> D202 49500 27800 19250 18000  ok
> 
> 
> 
> Although the query is 'top *salaries* by department', now that I look at the
> 
> other answers on that page, I see that every one of them provides the employee
> 
> record associated with the top salaries.  For that, TOPN could have pairs of
> 
> (salary,employee record address) cells.
> 
> 
> 
> I haven't submitted this as an answer to the 'Top rank per group' task on
> 
> Rosetta Code; I'm more tempted to provide a brute-force-with-high-level-data-structures answer.  I'd like to see how you would answer this task.
> 
> 
> 
> 
> 
> -- Julian

Hi!

Here a primitive network-db (after codasyl) alternative.
I suppose {employees}->{departments} relation is a function,
for every department(codomain) has a ring of employees(domain),
inserted orderly.
It is equivalent with a insert-sort, but I don't bother for now
for too many employees into a department.

 : new-node      ( -- anode )
        HERE DUP ,
;
: do-link       ( anode anew-node -- )
        OVER @ OVER ! SWAP !
;
        WORDLIST CONSTANT DEPT
: $create
        S" CREATE                                   " PAD SWAP MOVE
        32 UMIN PAD 8 + SWAP MOVE
        PAD 40 EVALUATE
;
: new-dm        ( $name $??? $sal -- dm-node )
        new-node >R
        >FLOAT IF F, THEN
        STRING,
        STRING,
        R>
;
: dm>sal        ( dm-node --   F: sal )
        CELL+ F@
;
: dm>name       ( dm-node -- $name )
        [ 1 CELLS 1 FLOATS + ] LITERAL +
        COUNT + COUNT
;
: new-cdm       ( $dept -- cdm-node )
        CURRENT @ >R DEPT CURRENT !
        $create new-node
        R> CURRENT !
;
: search-lesser ( cdm-node dm-node -- dm-node'' dm-node  )
        OVER >R
        BEGIN
                OVER @ OVER dm>sal dm>sal F>
                IF RDROP EXIT THEN
                SWAP @ SWAP
                OVER R@ =
                IF RDROP EXIT THEN
        AGAIN
;
: process       ( $name $??? $sal $dept -- )
        2DUP DEPT SEARCH-WORDLIST
        IF
                NIP NIP EXECUTE
        ELSE
                new-cdm
        THEN    ( $name $??? $sal cdm-node )
        >R new-dm R> SWAP       ( cdm-node dm-node )
        OVER DUP @ <>           ( non-empty ring )
        IF
                search-lesser
        THEN
        do-link
;
: .top          ( n cdm-node -- )
        TUCK 2>R
        0 SWAP @
        BEGIN   ( contor  node )
                2DUP 2R@        ( contor node contor node limit limit-node )
                ROT = -ROT = OR
                IF 2RDROP 2DROP EXIT THEN
                DUP dm>sal F. DUP dm>name TYPE CR
                @ SWAP 1+ SWAP
        AGAIN
;
: .dept         ( n -- )
        DEPT CELL+ @
        BEGIN
                DUP
        WHILE
                DUP ID. CR
                2DUP NAME>INT EXECUTE .top
                @
        REPEAT
        2DROP
;
: run
        BEGIN
                REFILL
        WHILE
                [CHAR] , PARSE [CHAR] , PARSE [CHAR] , PARSE [CHAR] , PARSE
                process
        REPEAT
;
: @top#         ( -- n )
        1 arg 0 0 2SWAP >NUMBER 2DROP D>S
;
STDIN ' run EXECUTE-PARSING-FILE  @top# .dept  bye


Now testing:

bash-4.2$ cat data.txt
Tyler Bennett,E10297,32000,D101
John Rappl,E21437,47000,D050
George Woltman,E00127,53500,D101
Adam Smith,E63535,18000,D202
Claire Buckman,E39876,27800,D202
David McClellan,E04242,41500,D101
Rich Holcomb,E01234,49500,D202
Nathan Adams,E41298,21900,D050
Richard Potter,E43128,15900,D101
David Motsinger,E27002,19250,D202
Tim Sampair,E03033,27000,D101
Kim Arlich,E10001,57000,D190
Timothy Grove,E16398,29900,D190
bash-4.2$ gforth dpt.fs < data.txt
D190 
D202 
D050 
D101 
bash-4.2$ gforth dpt.fs 2 < data.txt
D190 
57000. Kim Arlich
29900. Timothy Grove
D202 
49500. Rich Holcomb
27800. Claire Buckman
D050 
47000. John Rappl
21900. Nathan Adams
D101 
53500. George Woltman
41500. David McClellan
bash-4.2$ gforth dpt.fs 10 < data.txt
D190 
57000. Kim Arlich
29900. Timothy Grove
D202 
49500. Rich Holcomb
27800. Claire Buckman
19250. David Motsinger
18000. Adam Smith
D050 
47000. John Rappl
21900. Nathan Adams
D101 
53500. George Woltman
41500. David McClellan
32000. Tyler Bennett
27000. Tim Sampair
15900. Richard Potter

Enough testing! :)

Have a nice day,
humptydumpty

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

Page 1 of 2  [1] 2  Next page →

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

csiph-web