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

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

excercise from Robert L, please comment

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

Contents

  excercise from Robert L, please comment Andreas Klimas <klimas@w3group.de> - 2017-05-06 13:14 +0200
    Re: excercise from Robert L, please comment Alex <alex@rivadpm.com> - 2017-05-06 13:14 +0100
    Re: excercise from Robert L, please comment Andreas Klimas <klimas@w3group.de> - 2017-05-06 16:44 +0200
      Re: excercise from Robert L, please comment Alex <alex@rivadpm.com> - 2017-05-06 19:55 +0100
        Re: excercise from Robert L, please comment Alex <alex@rivadpm.com> - 2017-05-06 20:26 +0100
          Re: excercise from Robert L, please comment Andreas Klimas <klimas@w3group.de> - 2017-05-07 23:08 +0200
      Re: excercise from Robert L, please comment Ron Aaron <rambamist@gmail.com> - 2017-05-07 07:46 +0300
        Re: excercise from Robert L, please comment Ron Aaron <rambamist@gmail.com> - 2017-05-07 07:54 +0300
      Re: excercise from Robert L, please comment hughaguilar96@gmail.com - 2017-05-07 09:15 -0700
    Re: excercise from Robert L, please comment humptydumpty <ouatubi@gmail.com> - 2017-05-08 11:00 -0700
    Re: excercise from Robert L, please comment humptydumpty <ouatubi@gmail.com> - 2017-05-08 11:52 -0700
      Re: excercise from Robert L, please comment "HAA" <someone@microsoft.com> - 2017-05-09 13:20 +1000
        Re: excercise from Robert L, please comment humptydumpty <ouatubi@gmail.com> - 2017-05-10 00:26 -0700
          Re: excercise from Robert L, please comment "HAA" <someone@microsoft.com> - 2017-05-11 17:07 +1000
            Re: excercise from Robert L, please comment humptydumpty <ouatubi@gmail.com> - 2017-05-11 00:25 -0700
    Re: excercise from Robert L, please comment Julian Fondren <julian.fondren@gmail.com> - 2017-05-08 21:40 -0700
      Re: excercise from Robert L, please comment Julian Fondren <julian.fondren@gmail.com> - 2017-05-08 21:46 -0700

#58730 — excercise from Robert L, please comment

Hello,

I'm a newbie in Forth programming and want to learn to become
better. I took the example from Robert L as a starting point.
Any advices are welcome - thank you.

BTW, may be this is from any interest, I'm planning to use Forth
for my commercial work. It's in the area of insurance (not embedded).
I want to see how far I can get.

best wishes
Andreas Klimas


here ," CX16 HXY12 O6" constant formular

align
create l1 128 allot \ Buffer
create l2 128 allot
create >l1 l1 ,     \ Buffer-Seek-Pointer
create >l2 l2 ,

: ,l1 ( c--) >l1 @ ! 1 >l1 +! ;
: ,l2 ( c--) >l2 @ ! 1 >l2 +! ;

: digit? ( c--bool) [char] 0 [char] 9 1+ within ;
: $seek ( c-addr u xt) ( xt: c-addr u c--bool) \ subsequent iterate 
until bool becomes false
   >r
   begin
      dup while ( c-addr u)
         over c@ r@ execute ( c-addr u bool)
         0= if r> drop exit then ( c-addr' u') \ "xt execute" answered false
         1 /string
   repeat
   r> drop
;
: get-char ( c--bool)  \ called by $seek
   dup digit? if drop false else dup ,l1 then ;
: get-number ( c--bool)  \ called by $seek
   dup digit? if dup ,l2 else drop false then ;
: get-chars   ( c-addr u -- c-addr2 u2) ['] get-char $seek ;
: get-numbers ( c-addr u -- c-addr2 u2) ['] get-number $seek ;

: foo
   formular count ( c-addr u)

   begin
      bl skip (  c-addr u) \ remove leading white spaces

      get-chars
      bl ,l1  \ Seperate output
      bl skip \ remove white spaces
      get-numbers
      bl ,l2 \ Seperate output

      dup 0= ( c-addr u)
   until \ until ( c-addr 0)
   2 drop
   cr
   ." l1:" l1  >l1 @ l1 - type
   cr
   ." l2:" l2  >l1 @ l1 - type
   cr
;

[toc] | [next] | [standalone]

#58733

On 5/6/2017 12:14, Andreas Klimas wrote:
> Hello,
> 
> I'm a newbie in Forth programming and want to learn to become
> better. I took the example from Robert L as a starting point.
> Any advices are welcome - thank you.
> 
> BTW, may be this is from any interest, I'm planning to use Forth
> for my commercial work. It's in the area of insurance (not embedded).
> I want to see how far I can get.
> 
> best wishes
> Andreas Klimas
> 
> 

It compiles fine. Here's the output;

foo
l1:CX HXY O
l2:16 12 6
  ok[2]
.s [2] 8410358 0  ok[2]

Before talking about into the coding style, is that what you expect? 
(Note the stack contents after FOO.)

-- 
Alex

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

#58736

I forgot to clearify the exercise

"I have a string e.g. 'C6 H12 O6' that I wish to split up to give 2 strings
'C H O' and '6 12 6'."

I'm not sure if this was von Robert L. so if I'm wrong than sorry.
Anyway, I expanded the exercise a bit for not only using one
letter per symbol.

so the Teststring I have applied is "CX16 HXY12 O6", which is nonsens
for an chemist.

then, unfortunately there is a typo in the source:

>    until \ until ( c-addr 0)
>    2 drop

2 drop should be 2drop
sorry for inconvenience and thank you Alex for pointing out.




> Hello,
> 
> I'm a newbie in Forth programming and want to learn to become
> better. I took the example from Robert L as a starting point.
> Any advices are welcome - thank you.
> 
> BTW, may be this is from any interest, I'm planning to use Forth
> for my commercial work. It's in the area of insurance (not embedded).
> I want to see how far I can get.
> 
> best wishes
> Andreas Klimas
> 
> 
> here ," CX16 HXY12 O6" constant formular
> 
> align
> create l1 128 allot \ Buffer
> create l2 128 allot
> create >l1 l1 ,     \ Buffer-Seek-Pointer
> create >l2 l2 ,
> 
> : ,l1 ( c--) >l1 @ ! 1 >l1 +! ;
> : ,l2 ( c--) >l2 @ ! 1 >l2 +! ;
> 
> : digit? ( c--bool) [char] 0 [char] 9 1+ within ;
> : $seek ( c-addr u xt) ( xt: c-addr u c--bool) \ subsequent iterate 
> until bool becomes false
>    >r
>    begin
>       dup while ( c-addr u)
>          over c@ r@ execute ( c-addr u bool)
>          0= if r> drop exit then ( c-addr' u') \ "xt execute" answered false
>          1 /string
>    repeat
>    r> drop
> ;
> : get-char ( c--bool)  \ called by $seek
>    dup digit? if drop false else dup ,l1 then ;
> : get-number ( c--bool)  \ called by $seek
>    dup digit? if dup ,l2 else drop false then ;
> : get-chars   ( c-addr u -- c-addr2 u2) ['] get-char $seek ;
> : get-numbers ( c-addr u -- c-addr2 u2) ['] get-number $seek ;
> 
> : foo
>    formular count ( c-addr u)
> 
>    begin
>       bl skip (  c-addr u) \ remove leading white spaces
> 
>       get-chars
>       bl ,l1  \ Seperate output
>       bl skip \ remove white spaces
>       get-numbers
>       bl ,l2 \ Seperate output
> 
>       dup 0= ( c-addr u)
>    until \ until ( c-addr 0)
>    2 drop
>    cr
>    ." l1:" l1  >l1 @ l1 - type
>    cr
>    ." l2:" l2  >l1 @ l1 - type
>    cr
> ;

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

#58742

On 5/6/2017 15:44, Andreas Klimas wrote:
> I forgot to clearify the exercise
> 
> "I have a string e.g. 'C6 H12 O6' that I wish to split up to give 2 strings
> 'C H O' and '6 12 6'."

OK, thanks.

So the first thing I would do is break the task down, as you've done, 
but perhaps in a slightly different way. $SEEK is rather complex, what 
with its EXECUTE for either a number or a character.

Here's my solution. (I've written BL-SKIP, but your Forth may support 
SKIP. It's commonly available but not a standard word. As is APPEND 
+PLACE for ADD-CHAR.) It switches output strings based on the input 
character.


create char-string 256 allot \ counted buffer for characters
create num-string  256 allot \ counted buffer for numbers

variable target-string  \ pointer to the target string

: init-strings ( -- ) \ zero the output strings
     0 char-string c!
     0 num-string  c!
     char-string target-string ! ;

: add-char ( char string -- ) \ add char to a counted string
     dup c@ 1+ dup >r over c!  \ increment the length
     r> + c! ;                 \ store the char

: add-target ( char -- )
     target-string @ add-char ;

: bl-skip ( addr len -- addr' len' ) \ skip blanks
     dup if
       begin over c@ bl = over and
       while
         1 /string
       repeat
     then ;

: splitem ( addr len -- ) \ given a string, split them
     init-strings
     begin bl-skip dup     \ skip blanks
     while                 \ keep going while something left
       over c@             \ get character
       dup '0' '9' 1+ within if  \ select the output string
         num-string
       else
         char-string
       then
       dup target-string @ <> if \ if target changed
         bl add-target   \ add a blank
         target-string ! \ switch strings
       else drop then
       add-target         \ add the char
       1 /string          \ move up
     repeat 2drop ;

s" C6 H12 O6" splitem
cr char-string count type
cr num-string  count type


outputs

C H O
6 12 6
  ok





>> here ," CX16 HXY12 O6" constant formular
>>
>> align
>> create l1 128 allot \ Buffer
>> create l2 128 allot
>> create >l1 l1 ,     \ Buffer-Seek-Pointer
>> create >l2 l2 ,
>>
>> : ,l1 ( c--) >l1 @ ! 1 >l1 +! ;
>> : ,l2 ( c--) >l2 @ ! 1 >l2 +! ;
>>
>> : digit? ( c--bool) [char] 0 [char] 9 1+ within ;
>> : $seek ( c-addr u xt) ( xt: c-addr u c--bool) \ subsequent iterate 
>> until bool becomes false
>>    >r
>>    begin
>>       dup while ( c-addr u)
>>          over c@ r@ execute ( c-addr u bool)
>>          0= if r> drop exit then ( c-addr' u') \ "xt execute" answered 
>> false
>>          1 /string
>>    repeat
>>    r> drop
>> ;
>> : get-char ( c--bool)  \ called by $seek
>>    dup digit? if drop false else dup ,l1 then ;
>> : get-number ( c--bool)  \ called by $seek
>>    dup digit? if dup ,l2 else drop false then ;
>> : get-chars   ( c-addr u -- c-addr2 u2) ['] get-char $seek ;
>> : get-numbers ( c-addr u -- c-addr2 u2) ['] get-number $seek ;
>>
>> : foo
>>    formular count ( c-addr u)
>>
>>    begin
>>       bl skip (  c-addr u) \ remove leading white spaces
>>
>>       get-chars
>>       bl ,l1  \ Seperate output
>>       bl skip \ remove white spaces
>>       get-numbers
>>       bl ,l2 \ Seperate output
>>
>>       dup 0= ( c-addr u)
>>    until \ until ( c-addr 0)
>>    2 drop
>>    cr
>>    ." l1:" l1  >l1 @ l1 - type
>>    cr
>>    ." l2:" l2  >l1 @ l1 - type
>>    cr
>> ;
> 
> 


-- 
Alex

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

#58743

On 5/6/2017 19:55, Alex wrote:
> : splitem ( addr len -- ) \ given a string, split them
>      init-strings
>      begin bl-skip dup     \ skip blanks
>      while                 \ keep going while something left
>        over c@             \ get character
>        dup '0' '9' 1+ within if  \ select the output string
>          num-string
>        else
>          char-string
>        then
>        dup target-string @ <> if \ if target changed
>          bl add-target   \ add a blank
>          target-string ! \ switch strings
>        else drop then
>        add-target         \ add the char
>        1 /string          \ move up
>      repeat 2drop ;

This could be (dropping the possibly expensive BL SKIP)

: splitem ( addr len -- ) \ given a string, split them
     init-strings
     begin dup
     while                 \ keep going while something left
       over c@
       dup bl <> if        \ if not a blank
         dup '0' '9' 1+ within if  \ select the output string
           num-string
         else
           char-string
         then
         dup target-string @ <> if \ if target changed
           bl add-target   \ add a blank
           target-string ! \ switch strings
         else drop then
         add-target        \ add the char
       else drop then      \ drop the blank
       1 /string           \ move up
     repeat 2drop ;

-- 
Alex

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

#58790

Alex, I have studied your solution and got some points.
thank you very much!

the reason I have used the xt was a functional approach
derived from scheme.

Andreas


> On 5/6/2017 19:55, Alex wrote:
>> : splitem ( addr len -- ) \ given a string, split them
>> init-strings
>> begin bl-skip dup     \ skip blanks
>> while                 \ keep going while something left
>> over c@             \ get character
>> dup '0' '9' 1+ within if  \ select the output string
>> num-string
>> else
>> char-string
>> then
>> dup target-string @ <> if \ if target changed
>> bl add-target   \ add a blank
>> target-string ! \ switch strings
>> else drop then
>> add-target         \ add the char
>> 1 /string          \ move up
>> repeat 2drop ;
> 
> This could be (dropping the possibly expensive BL SKIP)
> 
> : splitem ( addr len -- ) \ given a string, split them
>      init-strings
>      begin dup
>      while                 \ keep going while something left
>        over c@
>        dup bl <> if        \ if not a blank
>          dup '0' '9' 1+ within if  \ select the output string
>            num-string
>          else
>            char-string
>          then
>          dup target-string @ <> if \ if target changed
>            bl add-target   \ add a blank
>            target-string ! \ switch strings
>          else drop then
>          add-target        \ add the char
>        else drop then      \ drop the blank
>        1 /string           \ move up
>      repeat 2drop ;

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

#58754

If you're willing to consider alternatives to ANS Forth, here's a
solution in 8th:

\ String 'C6 H12 O6' that I wish to split up to give 2 strings
\ 'C H O' and '6 12 6'."


\ Split the string on spaces:
"C6 H12 O6" " " s:/

\ For each string in the resultant array, split into head and tail
"" \ empty result of first concat
"" \ empty result of second concat
rot \ get the array into position
(
  \ stack is: "first"  "second"  index  string
  \ we dont' need the index
  nip

  \ split the string into head and tail
  1 s:/ a:open

  \ put the tail onto 'second'
  rot swap s:+ " " s:+

  \ do the same for the first
  >r s:+ " " s:+ r>
) a:each drop

\ We added an unneeded space at the end of both strings, so get rid of it:
s:trim swap s:trim
. cr . cr bye



The result is:
C H O
6 12 6


Of course there are other ways to accomplish the goal.  I could have
used regular-expressions, or I could have iterated the string directly.

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

#58755

On 05/07/17 07:46, Ron Aaron wrote:

> Of course there are other ways to accomplish the goal.  I could have
> used regular-expressions, or I could have iterated the string directly.

As, for example:

\ Split the string on a regex:
"C6 H12 O6" /([A-Z]+)([0-9]+)/ r:/
"" "" rot
(
  nip
  rot swap s:+ " " s:+
) a:each drop

.s bye

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

#58778

On Saturday, May 6, 2017 at 7:45:01 AM UTC-7, Andreas Klimas wrote:
> I forgot to clearify the exercise
> 
> "I have a string e.g. 'C6 H12 O6' that I wish to split up to give 2 strings
> 'C H O' and '6 12 6'."

That is not clarifying --- that is just an example --- I can't write the code unless I know the code is supposed to do.

It looks like you are finding blank-delimited substrings and then extracting the first char of each substring. 
Or maybe you are extracting the alphabetic chars of each substring. 
Or maybe you are extracting the numeric chars of each substring. 

There are a lot of possible algorithms that could convert that input into that output.

This reminds me of I.Q. tests in which the question is: 
"Here is a short series of numbers. What is the next number in the series?"
Then I say:
"Ummm...."

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

#58854

On Saturday, May 6, 2017 at 2:14:32 PM UTC+3, Andreas Klimas wrote:
> Hello,
> 
> I'm a newbie in Forth programming and want to learn to become
> better. I took the example from Robert L as a starting point.
> Any advices are welcome - thank you.
> 
> BTW, may be this is from any interest, I'm planning to use Forth
> for my commercial work. It's in the area of insurance (not embedded).
> I want to see how far I can get.
> 
> best wishes
> Andreas Klimas
> 
> 
> here ," CX16 HXY12 O6" constant formular
> 
> align
> create l1 128 allot \ Buffer
> create l2 128 allot
> create >l1 l1 ,     \ Buffer-Seek-Pointer
> create >l2 l2 ,
> 
> : ,l1 ( c--) >l1 @ ! 1 >l1 +! ;
> : ,l2 ( c--) >l2 @ ! 1 >l2 +! ;
> 
> : digit? ( c--bool) [char] 0 [char] 9 1+ within ;
> : $seek ( c-addr u xt) ( xt: c-addr u c--bool) \ subsequent iterate 
> until bool becomes false
>    >r
>    begin
>       dup while ( c-addr u)
>          over c@ r@ execute ( c-addr u bool)
>          0= if r> drop exit then ( c-addr' u') \ "xt execute" answered false
>          1 /string
>    repeat
>    r> drop
> ;
> : get-char ( c--bool)  \ called by $seek
>    dup digit? if drop false else dup ,l1 then ;
> : get-number ( c--bool)  \ called by $seek
>    dup digit? if dup ,l2 else drop false then ;
> : get-chars   ( c-addr u -- c-addr2 u2) ['] get-char $seek ;
> : get-numbers ( c-addr u -- c-addr2 u2) ['] get-number $seek ;
> 
> : foo
>    formular count ( c-addr u)
> 
>    begin
>       bl skip (  c-addr u) \ remove leading white spaces
> 
>       get-chars
>       bl ,l1  \ Seperate output
>       bl skip \ remove white spaces
>       get-numbers
>       bl ,l2 \ Seperate output
> 
>       dup 0= ( c-addr u)
>    until \ until ( c-addr 0)
>    2 drop
>    cr
>    ." l1:" l1  >l1 @ l1 - type
>    cr
>    ." l2:" l2  >l1 @ l1 - type
>    cr
> ;


Why not split in place? Something like this:

: <A?  ( c -- f  ;true if number or blank space)   [char] A <
;
: c#>=A  ( ca u -- u'  ;letters number of input-string)
  0 -rot bounds DO I c@ <A? 0= IF 1+ THEN LOOP
;
: croll  ( ca u --  ;char roll)
  over c@ >R 2dup + 1- >R  1- over 1+ -rot cmove 2R> c!
;
: +first-letter  ( ca u -- ca u  ;assure first char is a letter)
  BEGIN over c@ <A? WHILE 2dup croll REPEAT
;
: demux  ( ca u -- ca' u' ca" u")
\ last char of input-string should be blank for recognoscible output
  2dup 2dup c#>=A 0
  DO
      over c@ <A? IF +first-letter THEN
      1 /string
  LOOP
  2tuck nip -
;

Test:
S" Cu1 S1 O4 " demux type cr type .s cr

Output:
CuSO
4 1 1 <0>


Have a nice day,
hum9

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

#58858

On Saturday, May 6, 2017 at 2:14:32 PM UTC+3, Andreas Klimas wrote:
> Hello,
> 
> I'm a newbie in Forth programming and want to learn to become
> better. I took the example from Robert L as a starting point.
> Any advices are welcome - thank you.
> 
> BTW, may be this is from any interest, I'm planning to use Forth
> for my commercial work. It's in the area of insurance (not embedded).
> I want to see how far I can get.
> 
> best wishes
> Andreas Klimas
> 
> 
> here ," CX16 HXY12 O6" constant formular
> 
> align
> create l1 128 allot \ Buffer
> create l2 128 allot
> create >l1 l1 ,     \ Buffer-Seek-Pointer
> create >l2 l2 ,
> 
> : ,l1 ( c--) >l1 @ ! 1 >l1 +! ;
> : ,l2 ( c--) >l2 @ ! 1 >l2 +! ;
> 
> : digit? ( c--bool) [char] 0 [char] 9 1+ within ;
> : $seek ( c-addr u xt) ( xt: c-addr u c--bool) \ subsequent iterate 
> until bool becomes false
>    >r
>    begin
>       dup while ( c-addr u)
>          over c@ r@ execute ( c-addr u bool)
>          0= if r> drop exit then ( c-addr' u') \ "xt execute" answered false
>          1 /string
>    repeat
>    r> drop
> ;
> : get-char ( c--bool)  \ called by $seek
>    dup digit? if drop false else dup ,l1 then ;
> : get-number ( c--bool)  \ called by $seek
>    dup digit? if dup ,l2 else drop false then ;
> : get-chars   ( c-addr u -- c-addr2 u2) ['] get-char $seek ;
> : get-numbers ( c-addr u -- c-addr2 u2) ['] get-number $seek ;
> 
> : foo
>    formular count ( c-addr u)
> 
>    begin
>       bl skip (  c-addr u) \ remove leading white spaces
> 
>       get-chars
>       bl ,l1  \ Seperate output
>       bl skip \ remove white spaces
>       get-numbers
>       bl ,l2 \ Seperate output
> 
>       dup 0= ( c-addr u)
>    until \ until ( c-addr 0)
>    2 drop
>    cr
>    ." l1:" l1  >l1 @ l1 - type
>    cr
>    ." l2:" l2  >l1 @ l1 - type
>    cr
> ;

It can be done in place, like this:

: $roll  ( ca u --  ;roll char)
  over c@ >R 2dup + 1- >R  1- over 1+ -rot cmove 2R> c!
;
: >=A?  ( c -- f  ;true if letter)   [char] A >=
;
: c#<A  ( ca u -- u'  ;number of non-letters in input-string)
  tuck 0 -rot bounds DO I c@ >=A? IF 1+ THEN LOOP -
;
: +first-is-nonletter  ( ca u -- ca u  ;assure first char is a non-letter)
  BEGIN over c@ >=A? WHILE 1 /string REPEAT
;
: demux  ( ca u -- ca' u' ca" u")
  2dup 2dup c#<A 0
  DO
      over c@ >=A? IF +first-is-nonletter THEN
      2dup $roll
  LOOP
  2tuck nip -
;

Test:
S" Na2 S1 O4" 2dup type cr demux type cr type .s cr
S" Xy21 Z17 T43" 2dup type cr demux type cr type .s cr
 
Output:
Na2 S1 O4
NaSO
2 1 4<0> 
Xy21 Z17 T43
XyZT
21 17 43<0> 

--
Have a nice day,
hum9

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

#58868

Yet another using lib functions you may already have.

\ lib functions

: +string  ( a1 u1 a2 u2 -- a2 u3)  \ append string
  2swap swap 2over + 2 pick cmove + ;

: split ( a u c -- a2 u2 a3 u3 )  \ split at char
  >r 2dup r> scan 2swap 2 pick - ;

: c/string ( a u -- a2 u2 char )  \ extract start char
  1 /string over 1- c@ ;

: alpha? ( char -- flag )  upcase [char] A - #26 u< ;

\ version 1 - using HOLD buffer
: trivia ( a u -- a2 u2 a3 u3 )
  0 >r  pad 0
  begin  2swap bl skip  dup while
    bl split
    begin  2dup 0<> swap c@ alpha? and
    while  c/string >r  repeat  bl >r
    2rot +string s"  " 2swap +string
  repeat 2drop
  <#  begin  r> ?dup while  hold  repeat
  0 0 #> -trailing ;

s" Xy21 Z17 T43" 2dup cr type cr trivia cr type cr type
Xy21 Z17 T43
Xy Z T
21 17 43  ok

\ version 2 - for larger strings

: cappend ( c adr -- )  dup c@ 1+  2dup swap c!  + c! ;

here unused + 256 - value POCKET  \ temp storage

: +pocket ( c -- )  pocket  cappend ;

: trivia ( a u -- a2 u2 a3 u3 )
  0 pocket c!  pad 0
  begin  2swap bl skip  dup while
    bl split
    begin  2dup 0<> swap c@ alpha? and
    while  c/string +pocket  repeat  bl +pocket
    2rot +string s"  " 2swap +string
  repeat 2drop
  pocket count -trailing ;

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

#58932

On Tuesday, May 9, 2017 at 6:20:26 AM UTC+3, HAA wrote:
> Yet another using lib functions you may already have.
> 
> \ lib functions
> 
> : +string  ( a1 u1 a2 u2 -- a2 u3)  \ append string
>   2swap swap 2over + 2 pick cmove + ;
> 
> : split ( a u c -- a2 u2 a3 u3 )  \ split at char
>   >r 2dup r> scan 2swap 2 pick - ;
> 
> : c/string ( a u -- a2 u2 char )  \ extract start char
>   1 /string over 1- c@ ;
> 
> : alpha? ( char -- flag )  upcase [char] A - #26 u< ;
> 
> \ version 1 - using HOLD buffer
> : trivia ( a u -- a2 u2 a3 u3 )
>   0 >r  pad 0
>   begin  2swap bl skip  dup while
>     bl split
>     begin  2dup 0<> swap c@ alpha? and
>     while  c/string >r  repeat  bl >r
>     2rot +string s"  " 2swap +string
>   repeat 2drop
>   <#  begin  r> ?dup while  hold  repeat
>   0 0 #> -trailing ;
> 
> s" Xy21 Z17 T43" 2dup cr type cr trivia cr type cr type
> Xy21 Z17 T43
> Xy Z T
> 21 17 43  ok
> 
> \ version 2 - for larger strings
> 
> : cappend ( c adr -- )  dup c@ 1+  2dup swap c!  + c! ;
> 
> here unused + 256 - value POCKET  \ temp storage
> 
> : +pocket ( c -- )  pocket  cappend ;
> 
> : trivia ( a u -- a2 u2 a3 u3 )
>   0 pocket c!  pad 0
>   begin  2swap bl skip  dup while
>     bl split
>     begin  2dup 0<> swap c@ alpha? and
>     while  c/string +pocket  repeat  bl +pocket
>     2rot +string s"  " 2swap +string
>   repeat 2drop
>   pocket count -trailing ;


Yes, a trivial buffer overflow candidate.

It is a failure to see that problem could be solved
 at lower level(characters), without information loss.

Solving problem at parsing string level you use
an superfluous abstraction level.

Have a nice day,
hum9

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

#59048

humptydumpty wrote:
> On Tuesday, May 9, 2017 at 6:20:26 AM UTC+3, HAA wrote:
> ...
>
> Yes, a trivial buffer overflow candidate.
>
> It is a failure to see that problem could be solved
>  at lower level(characters), without information loss.
>
> Solving problem at parsing string level you use
> an superfluous abstraction level.
>
> Have a nice day,
> hum9

'Trivia' because as with all WJ's examples they are not 'real world'.
In a 'real world' application, you know what your inputs will be and
can therefore make informed decisions as to the complexity of code
necessary and the resources required.

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

#59050

On Thursday, May 11, 2017 at 10:08:45 AM UTC+3, HAA wrote:
> humptydumpty wrote:
> > On Tuesday, May 9, 2017 at 6:20:26 AM UTC+3, HAA wrote:
> > ...
> >
> > Yes, a trivial buffer overflow candidate.
> >
> > It is a failure to see that problem could be solved
> >  at lower level(characters), without information loss.
> >
> > Solving problem at parsing string level you use
> > an superfluous abstraction level.
> >
> > Have a nice day,
> > hum9
> 
> 'Trivia' because as with all WJ's examples they are not 'real world'.
> In a 'real world' application, you know what your inputs will be and
> can therefore make informed decisions as to the complexity of code
> necessary and the resources required.

Oh! I see now!

I'm sorry for harshness post.

Have a nice day,
hum9 

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

#58873

  : c+ ( c a -- )  count 2dup 1+ swap 1- c! + c! ;
  : letter? ( c -- f )  bl or [char] a [ char z 1+ ] literal within ;
  : digit? ( c -- f )  [char] 0 [ char 9 1+ ] literal within ;
  
  256 buffer: ratio
  256 buffer: chemicals
  
  : formula ( c-addr u -- )
    bounds ?do i c@
      dup letter? if chemicals c+ else
      dup digit? if ratio c+ else
      dup bl = if ratio c+ bl chemicals c+ else
      true abort" invalid character in formula"
    then then then loop ;
  
  s" C8 H10 N4 O2" formula
  cr ratio count type
  cr chemicals count type

Output:

  8 10 4 2
  C H N O

Very convenient input.

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

#58874

On Monday, May 8, 2017 at 11:40:05 PM UTC-5, Julian Fondren wrote:
>   : formula ( c-addr u -- )

    0 ratio c!  0 chemicals c!

Should probably be included though.

>     bounds ?do i c@
>       dup letter? if chemicals c+ else
>       dup digit? if ratio c+ else
>       dup bl = if ratio c+ bl chemicals c+ else
>       true abort" invalid character in formula"
>     then then then loop ;

[toc] | [prev] | [standalone]

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

csiph-web