Monday, 24 December 2012

Rebol Draw on Linux

Rebol works very well on  Linux, even DRAW, look these examples:

Iphone button


sz: 200x400
img: make image! sz
img/alpha: 255
draw img compose [
  pen none
  fill-pen linear (as-pair 0 sz/y / 2) -50.5 70.5 90.0 1.0 1.0
        45.45.47 9.9.11 108.113.117
  circle (as-pair sz/x - 115 sz/y / 2) 70.5
  fill-pen 1.0.5
  circle (as-pair sz/x - 115 sz/y / 2) 68.5
  reset-matrix
  fill-pen linear (as-pair sz/x - 115 sz/y / 2) -60.5 30.5 45.0 1.0 1.0
        161.164.169 161.164.169 89.94.100
  box (as-pair sz/x - 115 - 26 sz/y / 2 - 26) (as-pair sz/x - 115 + 26 sz/y / 2 + 26) 10.0
  fill-pen 1.0.5
  box (as-pair sz/x - 115 - 22 sz/y / 2 - 22) (as-pair sz/x - 115 + 22 sz/y / 2 + 22) 6.0
  reset-matrix
  fill-pen linear (as-pair 0 sz/y / 2 - 26) -50.5 100.5 90.0 1.0 1.0
        1.0.5.255 200.214.226.224 200.214.226.128
  shape [
    move 154x200
    arc 16x200 68.0 68.0
    arc 154x200 -149.0 68.0
  ]
]
view layout [
  backdrop 1.0.5
  image img
]

and neon effect:





my-font: make face/font [
name: "/usr/share/fonts/truetype/freefont/FreeSans.ttf"
;with your path to font you want to use
size: 64
style: [bold]
]
neon: "REBOL BAR"
coord: 30x15
inc: 0.25.25
draw-block: compose [
  line-join round font my-font
  pen (inc * 1 + 255.0.0.230) line-width 11 text vectorial coord neon
  pen (inc * 2 + 255.0.0.205) line-width 9 text vectorial coord neon
  pen (inc * 3 + 255.0.0.180) line-width 8 text vectorial coord neon
  pen (inc * 4 + 255.0.0.155) line-width 7 text vectorial coord neon
  pen (inc * 5 + 255.0.0.130) line-width 6 text vectorial coord neon
  pen (inc * 6 + 255.0.0.105) line-width 5 text vectorial coord neon
  pen (inc * 7 + 255.0.0.80) line-width 4 text vectorial coord neon
  pen (inc * 8 + 255.0.0.55) line-width 3 text vectorial coord neon
  pen (inc * 9 + 255.0.0.30) line-width 2 text vectorial coord neon
  pen (inc * 10 + 255.0.0.5) line-width 1 text vectorial coord neon
]
view/title layout [box black 450x200 effect [ draw draw-block ] ] "NEON"

Friday, 21 December 2012

Rebol 3 wiki

Since the rebol wiki mysteriously disappeared from R3 GitHUB, HostileFork made a backup, so if you need to share some information or need information, you can use the following wiki:
https://github.com/hostilefork/r3-hf/wiki

You can modify it with your GitHub account, as any wiki on GitHub.

Thank Hostile Fork

Thursday, 20 December 2012

Keyboard trainer

The following script is a game to learn typing Rebol keywords, you have to type the floating words before they reach the left side of the area.

Here the source code:



REBOL [
    Title: "Keyboard Trener"
    Date: 25-Mar-2006
    Version: 1.0.0
    File: %keyboar-trener.r
    Author: "Karol Gozlinski"
    Purpose: "Learn to write rebol words faster without looking at keyboard."
    Email: hali_tonic@o2.pl
]
random/seed now
dictionary: make block! 1000
foreach word first system/words [
  if all [
      value? to-word word
      not found? find to-string word "~"
      not block? word
      not object? word
      not image? word
  ][append dictionary to-string word ]
]
draw-dialect-block: []
screen-size: 400x128
movement-rate: 0:0:0.05
safty-area: 160
probability-adjustment: 2
if error? try [highscore: to-integer load %keyboard-trener-highscore][highscore: 0 ]
set-starting-parameters: does [
  probability: 1000
  score: 0
  stopped: false
  clear draw-dialect-block
  append draw-dialect-block [text 350x96 "Hello"]
  highscore-banner/font/color: yellow
]
view/title center-face layout [
  backdrop effect [ gradient 0x1 main-color linen ]
  across
  score-banner: vh2 left (screen-size/x / 2) bold yellow ""
  highscore-banner: vh2 right (screen-size/x / 2 - 10) bold yellow ""  
  below
  screen: image linen screen-size effect [draw draw-dialect-block] rate movement-rate feel [
      engage: func [face action event][
        if any [ stopped action <> 'time] [return]
        score-banner/text: join "Score : " next form 10000000 + score
        show score-banner
        if score > highscore [
            highscore: score
            highscore-banner/font/color: green
        ]
        highscore-banner/text: join "Highscore : " next form 10000000 + highscore
        show highscore-banner
        forskip draw-dialect-block 3 [
            if (draw-dialect-block/2/x: draw-dialect-block/2/x - 1) < 0 [
              clear draw-dialect-block
              append draw-dialect-block compose [
                  text ( screen-size / 2 - 40x10) "GAME OVER"
              ]
              stopped: true
              save %keyboard-trener-highscore highscore
            ]
        ]
        show screen
        if stopped [return]
        probability: probability + probability-adjustment
        if all [not empty? draw-dialect-block probability < random 100000] [return]
        empty-slots: make block! 20
        for y 0 screen-size/y 16 [append empty-slots y]
        remove back tail empty-slots
        foreach [feat pos word] draw-dialect-block [
            if (screen-size/x - pos/x) < safty-area [
              remove-each s empty-slots [ s = pos/y]
            ]
        ]
        if empty? empty-slots [return]
        append draw-dialect-block compose [
            text
            ( as-pair screen-size/x random/only empty-slots)
            ( lotto: random/only dictionary)
        ]
        probability: probability - power length? lotto 3
      ]
  ]
  text navy "INSTRUCTION : Write flying words before they hit left margin !!!"
  across
  input-field: field 225 [
      if all [ stopped empty? input-field/text][set-starting-parameters]
      remove-each [feat pos word] draw-dialect-block [
        either word = input-field/text [
            probability: probability + power length? input-field/text 3
            score: score + length? input-field/text
            true
        ][false]
      ]
      clear input-field/text
      focus input-field
  ]
  btn 80 linen "Restart" [set-starting-parameters]
  btn 80 linen "Quit" [quit]
  return
  text "(c) 2006 Karol Gozlinski"
  do [
      score-banner/saved-area: true
      highscore-banner/saved-area: true
      set-starting-parameters
      focus input-field
  ]
] {Keyboard Trener}

Wednesday, 19 December 2012

Playing MP3

The following script was made by Nick Antonaccio to show ho to use external library and how to play sound with Rebol. The script uses just a windows library (libwmp3.dll), so it works only on Windows; but you can adapt easily it to your OS.
Here the source:

REBOL [
    File: %jukebox.r
    Date: 10-Aug-2009
    Title: "Jukebox - Wav/Mp3 Player"
    Author:   Nick Antonaccio
    Purpose: {
        Play .wav and .mp3 files from a selection list.
        Taken from the tutorial at http://musiclessonz.com/rebol.html
    }
]
if not exists? %libwmp3.dll [
    write/binary %libwmp3.dll
    read/binary http://musiclessonz.com/rebol_tutorial/libwmp3.dll
]
lib: load/library %libwmp3.dll
Mp3_Initialize: make routine! [
    return: [integer!]
] lib "Mp3_Initialize"
Mp3_OpenFile: make routine! [
    return: [integer!]
    class [integer!]
    filename [string!]
    nWaveBufferLengthMs [integer!]
    nSeekFromStart [integer!]
    nFileSize [integer!]
] lib "Mp3_OpenFile"
Mp3_Play: make routine! [
    return: [integer!]
    initialized [integer!]
] lib "Mp3_Play"
Mp3_Stop: make routine! [
    return: [integer!]
    initialized [integer!]
] lib "Mp3_Stop"
Mp3_Destroy: make routine! [
    return: [integer!]
    initialized [integer!]
] lib "Mp3_Destroy"
Mp3_GetStatus: make routine! [
    return: [integer!]
    initialized [integer!]
    status [struct! []]
] lib "Mp3_GetStatus"
status: make struct! [
    fPlay [integer!]
    fPause [integer!]
    fStop [integer!]
    fEcho [integer!]
    nSfxMode [integer!]
    fExternalEQ [integer!]
    fInternalEQ [integer!]
    fVocalCut [integer!]
    fChannelMix [integer!]
    fFadeIn [integer!]
    fFadeOut [integer!]
    fInternalVolume [integer!]
    fLoop [integer!]
    fReverse [integer!]
] none
play-sound: func [sound-file] [
    wait 0
    wait-flag: true
    ring: load sound-file
    sound-port: open sound://
    insert sound-port ring
    wait sound-port
    close sound-port
    wait-flag: false
]
wait-flag: false
change-dir %/c/Windows/media
waves: []
foreach file read %. [
    if ((%.wav = suffix? file) or
        (%.mp3 = suffix? file)) [append waves file]
]
initialized: Mp3_Initialize
view center-face layout [
    vh2 "Click a File to Play:"
    file-list: text-list data waves [
        Mp3_GetStatus initialized status
        either %.mp3 = suffix? value [
            if (wait-flag <> true) and (status/fPlay = 0) [
                file: rejoin [to-local-file what-dir "\" value]
                Mp3_OpenFile initialized file 1000 0 0
                Mp3_Play initialized
            ]
        ] [
            if (wait-flag <> true) and (status/fPlay = 0) [
                if error? try [play-sound value] [
                    alert "malformed wave"
                    close sound-port
                    wait-flag: false
                ]
            ]
        ]
    ]
    across
    btn "Change Folder" [
        change-dir request-dir
        waves: copy []
        foreach file read %. [
            if ((%.wav = suffix? file) or
            (%.mp3 = suffix? file)) [append waves file]
        ]
        file-list/data: waves
        show file-list
    ]
    btn "Stop" [
        close sound-port
        wait-flag: false
        if (status/fPlay > 0) [Mp3_Stop initialized]
    ]
]
Mp3_Destroy initialized
free lib

Rebol 3 today

Hi, the release of the source code on GitHub take me a lot of time and I hadn't time to post something.
I am so excited of this event, I see a lot of people participating together, solving bugs, writing docs, all this is a dream come true.
On the other side I notice some people making old errors, that could ruin Rebol3:
  • dividing resource on multiple site (using curecode instead of GitHub)
  • closing the public wiki

My point of view is the following: GitHub is an excellent platform to develop software, we must use it as much as possible, so our energies will be concentrate and effective.
Asking people to register and using another site for bug submitting is a non-sense, it double the requests and make extremely difficult to find if an error is already discussed and double the time to check the requests.
One of the biggest problem of documentation with Rebol 2 was the total absence of a public wiki, documentation lacked on simple topic and was too deep about very specific topic. Github gives the public wiki, where everybody with a GitHub account can contribute, in few days there were a lot of contribution and today it was disappeared.
I hope the the administrators of the rebol source will not repeat the errors of Rebol 2.

Friday, 14 December 2012

Json

Json is a format to send data, if you have an application that it uses json data, the following script converts rebol data to json data.
A simple block of rebol is simpler and more efficient to send and receive data, since rebol interpreter can understand many types of data directly.
Don't try to copy and paste the script in the console, there are some unicode that wouldn't be copied, do directly the script. The script is here: http://www.rebol.org/view-script.r?script=json.r
the you can type:

do %json.r

and you have the rebol-to-json function to convert rebol data in json data. Look the following examples:

>> rebol-to-json 12
== "12"
>> rebol-to-json [12 "Hello"]
== {[12, "Hello"]}
>> rebol-to-json [12 "Hello" $33]
== {[12, "Hello", "$33.00"]}
>> a: make object! [speed: 23 greeting:"Good morning"]
>> rebol-to-json a
== {{"speed": 23, "greeting": "Good morning"}}

Thursday, 13 December 2012

Rebol 3 sources released!

It's official, on https://github.com/rebol/r3 the sources of Rebol are released.
Now Rebol development depends on you!


Monday, 10 December 2012

Rebol cannon game

Here an example of a game with multiple layers, scrolling clouds and more. Game objective is to hit the ground where is the point of the red arrow:
I commented the code, but if you need further clarification, comment the post or send me an email; here the source:
Rebol [title: "RebCannon"
author: "Massimiliano Vessi"
]
;starting parameters
n: 0
either not exists? %rebcannon.score [score-list: copy [] ] [score-list: load %rebcannon.score]
if not exists? %cloud.png [request-download/to   http://www.maxvessi.net/rebsite/cloud.png   %cloud.png   ]
cloud: load %cloud.png
vx: 5 + (100 * 0.5 * cosine 45)
vy: 5 + ( 100 * 0.5 * sine 45 )
g: 9.8
an: 45
cannon: 10x10
wind:   0
wa: 100x10
random/seed now
tt: 0
ber: 180
;this scroll clouds when there is wind
clouds-moving: func [] [
    tt: tt + (wind / 5)
    if tt < -1100 [tt: 1100]
    if tt > 1100 [tt: -1100]
    compose/deep
        [draw[
            translate (as-pair tt 0)
            image cloud -700x10   -650x50  
            image cloud -400x20   -360x70  
            image cloud 200x10   240x50  
            image cloud 400x25   470x90
            image cloud 700x15   770x80
            ]]
       
    ]
;this trace the parabolic arc of the projectile and check if you centered the target
percorso: func [vx vy /local temp a b m q] [
    sx: sy: 0
    temp: copy select camp/effect 'draw
    color: random 255.255.255
    append temp reduce ['pen color 'line 0x0 ]  
    t: 0
    while [sy >= 0 ]   [
        ++ t
        sx: ( vx * t ) + (wind * t )
        sy:   ( -1 / 2 * g * (t ** 2) ) + (vy * t)
        append temp as-pair sx sy
        camp/effect: compose/only   [ draw   (temp) flip 0x1]
        show camp
        wait 0.1
        ]
    ;let's calculate the intercpet in Y=0
    ; Y = m x + q
    reverse temp    
    a: first temp
    b: second temp      
    m:   (b/y - a/y) / (b/x - a/x)
    q:   a/y - ( (a/y - b/y ) / ( a/x - b/x) * a/x )
    arrivo: (-1 * q / m)
    ;check target with a +/-5 px of approximation
    if all [arrivo < (ber + 5)
        (ber - 5) < arrivo
        ] [alert   "Good, try next level"
            new-level
            ]
    reverse temp
    ]
;this recreate the random target arrow
crea-bersaglio: func [ber][
    compose/deep [draw [pen red arrow 1x2   line (as-pair ber   30 ) (as-pair ber 0 )     ] flip 0x1]
    ]
;new level recreation  
new-level: func [/reset ] [
    until [ber: random 399  
        ber > 20
        ]
    bersaglio/effect:   crea-bersaglio ber
    camp/effect: copy [draw [] ]  
    wind: (random/only [-1 1] ) * ((random 30) - 1)
    wa: 100x10 + ( as-pair (10 + wind)   0 )
    if reset [
        score: reduce [hits/text   stats/text   request-text/title "Type your name" ]
        append/only score-list score        
        sort score-list
        reverse score-list
        save %rebcannon.score   score-list
        hits/text: "-1" ;since it's always added 1 add the end of this function
        stats/text: "0 %"
        shots/text: "0"
        show [stats shots]
        ]
    hits/text:   to-string ((to-integer hits/text) + 1)  
    show [camp cielo bersaglio hits]
    ]
;main layout
view layout [
cielo: box 400x200 effect [gradient 0x1 135.203.255 white draw [arrow 1x2   line 100x10 wa   ] ]
panel [
label "Power:"
label "Angle:"
return
powcan: slider 100x15   0.5 [ ;power
    vx: 5 + (100 * value * cosine an)
    vy: 5 + ( 100 * value * sine an )
    ]
ancan: slider 100x15 0.5 [
    an: 90 *   value
    vx: 5 + (100 * powcan/data * cosine an)
    vy: 5 +   (100 * powcan/data * sine an)
    cannon: as-pair (1.412 * 10 * cosine an )   (1.412 * 10 * sine an)
    show carro
    ] ;angle
return  
text "Hits:"    
text "Shots:"
text "Statistic:"
return
hits: text "0" 100
shots: text "0" 100
stats: text "0 %" 100
]
across
button "Shot"   [
    percorso vx vy
    shots/text: to-string ((to-integer shots/text) + 1)
    stats/text:   reform [(   to-integer (to-integer hits/text) / (to-integer shots/text) * 100 ) "%" ]
    show [shots stats]
    ]
button "New game" [new-level/reset ]
aaa: button "Score list" [view/new/title layout [
        title "Score list"
        panel [
            across
            text bold "Hits" 40
            text bold "Stats" 40            
            text bold "Name" 100
            return
            sl: list 180x200 [text 40 return text 40 return text 100 ] supply [
                count: count + n
                ;just to avoid errors on path! I added this check:
                either   score-list/:count [ face/text:   score-list/:count/:index ] [face/text:   none]
                ]              
            scroller 16x200 [
                n:   to-integer (face/data * (length? score-list) )          
                show sl
                ]
            ]                  
        ] "Score list"]
button 24x24 pink "?" [notify {Try to hit the ground where point the red arrow. Contact: maxint@tiscali.it} ]      
at cielo/offset
camp: box   400x200 effect [draw [] ]
at cielo/offset
clouds: box 400x200 rate 9 effect clouds-moving   feel [engage: func [f a e][f/effect:   clouds-moving   show f]]
at cielo/offset
carro: box 400x200 effect [draw [fill-pen black pen black box 0x0 5x5 line 0x0 cannon] flip 0x1]
at cielo/offset
bersaglio: box 400x200 effect crea-bersaglio ber
]

Friday, 7 December 2012

Removing superfluos data from JPG images

I found a script that remove unnecessary data form JPG images, so I added a GUI:
Here the source of the script:

Rebol [title: "JPG purger"]
jpg-analyse: func[
    "Analyses the JPG file and tries to remove some unnecessary infos from file"
    file [file! url! binary!]   "JPG file to analyse"
    /remove tags-to-remove [block!] {If not specified these tags are removed:
            ["Photoshop 3.0" "ICC_PROFILE" "Adobe" "Ducky"] if presents}

    /quiet "Will not print informations"
    /local
        to-int buf   jfif version units Xdensity Ydensity
        Xthumbnail Ythumbnail rgb length lng identifier data APP0
][
    if not remove [
        tags-to-remove: [
            "Photoshop 3.0"
            "ICC_PROFILE"
            "Adobe"
            "Ducky"
        ]
    ]
    img: either binary? file [file][read/binary file]
    newimg: make binary! length? img
   
    to-int: func[i][to-integer to-binary i]
    msg: func[m][if not quiet [print m]]
    JFIF: [
        ["JFIF^@"
            copy version 2 skip (
                version: (to-int version/1) + ((to-int version/2) / 100)
            )
            copy units 1 skip (units: to-int units)
            copy Xdensity 2 skip
            copy Ydensity 2 skip
            copy Xthumbnail 1 skip
            copy Ythumbnail 1 skip
            copy rgb to end
        ] (
           
            print "JFIF HEADER:"
            print ["^-   version:" version]
            print ["^-     units:" pick [
                "no units, X and Y specify the pixel aspect ratio"
                "X and Y are dots per inch"
                "X and Y are dots per cm"
                ] 1 + units
            ]
            print ["^-   density:" to-pair reduce [to-int Xdensity to-int Ydensity]]
            print ["^-thumbnail:" to-pair reduce [
                to-int Xthumbnail
                to-int Ythumbnail]
            ]
        )
    ]
    parse/all img [
        copy buf thru "ÿØ" (insert tail newimg buf)
        some [
            "ÿ"
            copy APP0 1 skip
            copy length 2 skip (lng: (to-int length) - 2)
            copy data lng skip (
                identifier: none
                either APP0 = "à" [
                    if not quiet [parse/all data JFIF]
                ][
                    if not none? data [
                    parse/all data [
                        copy identifier to "^@" 1 skip
                        to end
                    ]
                    ]
                ]
                either any [
                    found? find tags-to-remove identifier
                    APP0 = "þ"   ;info about the creator's program
                ][
                    msg either none? identifier [
                        ["Removed data:" data]
                    ][
                        ["Removed tag" mold identifier "lenght:" lng + 4]
                    ]
                ][
                    insert tail newimg rejoin ["ÿ" APP0 length data]
                ]
            )
        ]
        copy buf to end (insert tail newimg buf)
    ]
    msg ["Original   image:" length? img "B"]
    msg ["Optimised image:" length? newimg "B"]
    newimg
]
temp: temp2: none
view layout [
    h1 "JPG purger"
    btn "Select file..." [temp: request-file/only/filter   "*.jpg"  
        if temp [
            a/image: load temp
            temp2: jpg-analyse/quiet read/binary temp
            b/image: load temp2
            aa/text: reform ["Original image " (round/to ((length? img) / 1000) 0.01)   "kb size" ]          
            bb/text: reform ["Removed superfluos data image " (round/to ((length? newimg) / 1000) 0.01) "kb size" ]
            show [a aa b bb]
            ]
        ]
    panel [
    a: image 100x100 effect [aspect ]
    aa: text 100x100
    return
    box 2x200 black
    return
    b: image 100x100 effect [aspect ]
    bb: text 100x100
    ]
    btn "Save..." [write/binary (to-file join (request-text/title/default   "Choose new image name:"   "my-image")   %.jpg )   temp2 ]
    ]
If you need to edit more than one file, for a example all images in a folder, you can use the original script (see below) and launch:
replace-jpgs
here the original source code:
REBOL [
    Title: "JPG analyse"
    Date: 4-Jan-2002/18:22:48+1:00
    Version: 1.0.0
    File: %jpg-analyse.r
    Author: "Oldes"
    Usage: "NEWjpg: jpg-analyse %/e/testjpg.jpg"
    Purpose: {To remove some data from the JPG files to make them smaller.
^-For example files from Adobe contains so many other informations that the file is twice bigger than may be.}
    Email: oliva.david@seznam.cz
]
jpg-analyse: func[
    "Analyses the JPG file and tries to remove some unnecessary infos from file"
    file [file! url! binary!]   "JPG file to analyse"
    /remove tags-to-remove [block!] {If not specified these tags are removed:
            ["Photoshop 3.0" "ICC_PROFILE" "Adobe" "Ducky"] if presents}

    /quiet "Will not print informations"
    /local
        img to-int buf newimg jfif version units Xdensity Ydensity
        Xthumbnail Ythumbnail rgb length lng identifier data APP0
][
    if not remove [
        tags-to-remove: [
            "Photoshop 3.0"
            "ICC_PROFILE"
            "Adobe"
            "Ducky"
        ]
    ]
    img: either binary? file [file][read/binary file]
    newimg: make binary! length? img
   
    to-int: func[i][to-integer to-binary i]
    msg: func[m][if not quiet [print m]]
    JFIF: [
        ["JFIF^@"
            copy version 2 skip (
                version: (to-int version/1) + ((to-int version/2) / 100)
            )
            copy units 1 skip (units: to-int units)
            copy Xdensity 2 skip
            copy Ydensity 2 skip
            copy Xthumbnail 1 skip
            copy Ythumbnail 1 skip
            copy rgb to end
        ] (
           
            print "JFIF HEADER:"
            print ["^-   version:" version]
            print ["^-     units:" pick [
                "no units, X and Y specify the pixel aspect ratio"
                "X and Y are dots per inch"
                "X and Y are dots per cm"
                ] 1 + units
            ]
            print ["^-   density:" to-pair reduce [to-int Xdensity to-int Ydensity]]
            print ["^-thumbnail:" to-pair reduce [
                to-int Xthumbnail
                to-int Ythumbnail]
            ]
        )
    ]
    parse/all img [
        copy buf thru "ÿØ" (insert tail newimg buf)
        some [
            "ÿ"
            copy APP0 1 skip
            copy length 2 skip (lng: (to-int length) - 2)
            copy data lng skip (
                identifier: none
                either APP0 = "à" [
                    if not quiet [parse/all data JFIF]
                ][
                    if not none? data [
                    parse/all data [
                        copy identifier to "^@" 1 skip
                        to end
                    ]
                    ]
                ]
                either any [
                    found? find tags-to-remove identifier
                    APP0 = "þ"   ;info about the creator's program
                ][
                    msg either none? identifier [
                        ["Removed data:" data]
                    ][
                        ["Removed tag" mold identifier "lenght:" lng + 4]
                    ]
                ][
                    insert tail newimg rejoin ["ÿ" APP0 length data]
                ]
            )
        ]
        copy buf to end (insert tail newimg buf)
    ]
    msg ["Original   image:" length? img "B"]
    msg ["Optimised image:" length? newimg "B"]
    newimg
]
replace-jpgs: func[
    "Replaces all JPG files"
    /local path tsz1 tsz2 sz1 sz2 ext img newimg modes
][
    path: to-file ask {Directory? }
    if empty? path [path: %./]
    if (last path) <> #"/" [append path #"/"]
    if not exists? path [print [path "does not exist"] halt]
    tsz1: 0
    tsz2: 0
    foreach file files: read path [
        either dir? path/:file [
            foreach newfile read path/:file [append files file/:newfile]
        ][
            ext: last (parse mold path/:file ".")
            if ext = "jpg" [
                if error? try [
                img: read/binary path/:file
                modes: get-modes path/:file [modification-date owner-write]
                if not last modes [
                    ;change back tail modes true
                    ;set-modes path/:file modes
                    ;uncomment if you want to replace locked files
                ]
                sz1: length? img
                newimg: jpg-analyse/quiet img
                sz2: length? newimg
                tsz1: tsz1 + sz1
                tsz2: tsz2 + sz2
                if sz1 > sz2 [
                    write/binary path/:file newimg
                    set-modes path/:file modes
                    print [path/:file sz1 sz2]
                ]
                ][print ["ERROR: " path/:file]]
            ]
        ]
    ]
    print ["Before: " tsz1]
    print ["Now:     " tsz2]
    print ["Removed:" tsz1 - tsz2]
]                                                                                                                                                



Thursday, 6 December 2012

Email server

An email server isn't an obscure software, is just a software that sort and deliver email. Yes, you are right, an email server in rebol is extremely easy, look here:
REBOL [
    Title: "Jobbot Email Server"
    Date: 8-Sep-1999
    File: %jobbot.r
    Author: "Carl Sassenrath"
    Purpose: {
        The email server we use for processing job related
        email.
    }
]
test-mode: off               ; test mode (no send/save)

;---Setup options and controls:
archive:   %msgs               ; directory to hold msgs
counter:   %msgcount.txt       ; message counter
sender:   jobs@rebol.com
manager:   carl@rebol.com
target:   [brenda@rebol.net carl@rebol.com]
insiders: [; don't send thank you to these people
    brenda@rebol.net
    brenda@rebol.com
    jobs@rebol.com
    carl@rebol.com
    carl@rebol.net
]
mailbox: open [;--- Setup mailbox message port object:
    scheme: 'pop
    host: "mail.rebol.net"
    user: "jobs"
    pass: load %theword.r
]
set-net [jobs@rebol.com mail.rebol.net]
if test-mode [;replace functions to prevent actual operation
    save: func [file data] [print ["saving file:" file]]
    send: func [to msgs] [print ["sending to:" to "From:" from]]
    resend: func [to from msg] [
        print ["resending to:" to "From:" from newline ];msg]
        ;confirm "Next?"
    ]
]
quit-mail: func [] [close mailbox quit]
thanks: {I got your message.
Thank you for contacting us at REBOL Technologies. We will
review your message soon.
-Jobbot
}

process-msg: func [raw-mail] [
    mail: import-email raw-mail
    if any [
        find first mail/from "MAILER-DAEMON"
        find first mail/from "postmaster"
        find first mail/from jobs@rebol
        find first mail/from list@rebol
        not any [
            find mail/to jobs@rebol.com
            find mail/to jobs@rebol.net
        ]
    ][probe mail/to exit]
    save counter count: count + 1
    save archive/:count raw-mail
    print [count "From:" mail/from "Subject:" mail/subject "Date:" mail/date]
    print who: first either mail/reply-to [mail/reply-to][mail/from]
    sub: insert find/tail raw-mail "Subject:" reduce [" #" count ": "]
    insert find sub newline reduce [newline "X-Tag: jobbot processed"]
    either find insiders who [print "internal" ][send who thanks ]
    foreach user target [resend user manager raw-mail]
]
do-jobbot: func [] [
    print now
    count: load counter
    if tail? mailbox [print "no mail" quit-mail]
    print [length? mailbox "new messages"]
    while [not tail? mailbox] [
        process-msg msg: first mailbox
        either test-mode [mailbox: next mailbox][remove mailbox]
    ]
    print [count "messages to date"]
    quit-mail
]
do-jobbot