[Delphi] Updating SysTray

I'd been lurking at ITtoolbox for a while and saw this request for help with updating the system tray.

I've had similar problems myself. For instance, if you use boost or some similar process-control tool to kill the Skype.exe and SkypePM.exe programs, the processes disappear from memory but the system tray still shows the Skype icon until you move the mouse over the icon. Then the tray refreshes, the Skype icon disappears and the remaining icons rearrange.

On Experts Exchange I found a bit of Delphi code which moves the mouse over the systray (using system messages rather than moving the mouse pointer itself.) This convinces Windows to update the systray. Because not everyone has an Experts Exchange membership, I've turned the code into a COM DLL, which you can download. Source is included (Artistic2 license.) A copy of the original Experts Exchange code can be found here.

Once you've registered the DLL (regsvr32 UpdateSysTray.DLL) you can use it in anything that supports ActiveX/COM objects. For example, in VBScript:

set o = createobject("UpdateSysTray.UST") o.UpdateSysTray()

© Copyright Bruce M. Axtens, 2008

[Misc] Trouble is, I don't know how to program in PHP

Which Programming Language are You?

[VBScript] StandardLibrary.zip

For those interested, who haven't been able to download it recently, here's the latest iteration of StandardLibrary.vbs. Now it's called stdlib.vbs and can be obtained from my boost account at the Perth Linux Users Group.

There have been a few changes, mostly additional functions and the odd tweak in favour of better functionality.

Significant in the additions are a few functions for sending emails: Blat, BlatAttachment, ErrorEmail, ErrorEmailApp, RedemptionSend and ThunderbirdSend. If I remember correctly, ErrorEmail has been around for a while, but is included here for completeness sake.

Function Blat( sTo, sSubj, sText ) Const TIMEOUT_LIMIT = 60000 Const TIMEOUT_SLICE = 500 Const BLAT_CMD = "c:\bin\Blat.exe [1] -to [2] -subject [3] -server mail.quux.foo.com -f bar@baz.quux -u foo@bar.baz -pw xxxx -unicode" Dim nTimeout Dim bTimedOut Dim oExec Dim sCmd Dim sFolder Dim sName Dim sPath Dim sSave Dim sResult Dim aResult Dim bResult Dim bDontCare sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER ) sName = oFSO.GetTempName sPath = oFSO.BuildPath( sFolder, sName) WriteFileU sPath, sText, WF_CREATE sCmd = Subst( BLAT_CMD, Array( DQ( sPath ), sTo, DQ( sSubj ) )) bTimedOut = False nTimeout = TIMEOUT_LIMIT Set oExec = oShell.Exec( sCmd ) bDontCare = SetPriority( "blat.exe", REALTIME_PRIORITY ) Do While oExec.Status = 0 Doze TIMEOUT_SLICE nTimeout = nTimeout - TIMEOUT_SLICE If nTimeout < 1 Then bTimedOut = True Exit Do End If Loop sResult = oExec.StdOut.ReadAll aResult = Split( sResult, vbCRLF ) If bTimedOut Or Left( aResult( 2 ), 6 ) = "Error:" Then bResult = False Else bResult = True End If Blat = Array( bResult, sResult ) End Function

Function BlatAttachment( sTo, sSubj, sText, aAttachments ) Const TIMEOUT_LIMIT = 30000 Const TIMEOUT_SLICE = 500 Const BLAT_CMD = "c:\bin\Blat.exe [1] -to [2] -subject [3] -server mail.quux.foo.com -f bar@baz.quux -u foo@bar.baz -pw xxxx -unicode" Dim nTimeout Dim bTimedOut Dim oExec Dim sCmd Dim sFolder Dim sName Dim sPath Dim sSave Dim sResult Dim aResult Dim bResult Dim bDontCare sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER ) sName = oFSO.GetTempName sPath = oFSO.BuildPath( sFolder, sName) WriteFileU sPath, sText, WF_CREATE sCmd = Subst( BLAT_CMD, Array( DQ( sPath ), sTo, DQ( sSubj ) )) bTimedOut = False nTimeout = TIMEOUT_LIMIT Set oExec = oShell.Exec( sCmd ) bDontCare = SetPriority( "blat.exe", REALTIME_PRIORITY ) Do While oExec.Status = 0 Doze TIMEOUT_SLICE nTimeout = nTimeout - TIMEOUT_SLICE If nTimeout < 1 Then bTimedOut = True Exit Do End If Loop sResult = oExec.StdOut.ReadAll aResult = Split( sResult, vbCRLF ) If bTimedOut Or Left( aResult( 2 ), 6 ) = "Error:" Then bResult = False Else bResult = True End If Blat = Array( bResult, sResult ) End Function

Const SLICE = 1024 Sub ErrorEmail( vTo, sSubj, sText ) Dim sCC Dim sTo If IsArray( vTo ) Then sTo = Escape( vTo( 0 ) ) sCC = Escape( vTo( 1 ) ) Else sTo = Escape( vTo ) End If sSubj= Escape( sSubj ) sText = Escape( sText ) If IsArray( vTo ) Then sCmd = Subst( "mailto:[1]?subject=[3]&cc=[2]&body=[4]", Array( sTo, sCC, sSubj, sText ) ) Else sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) ) End If '~ MsgBox sCmd On Error Resume Next oShell.Run sCmd ', 0, True If Err.Number <> 0 Then document.parentwindow.clipboardData.SetData "text", UnEscape( sText ) MsgBox "Windows didn't like the size of message. I've put it on the clipboard" sCmd = Subst( "mailto:[1]?subject=[2]", Array( sTo, sSubj ) ) oShell.Run sCmd, 0, True HTASleep 5000 End If End Sub

Sub ErrorEmailApp( cApp, vTo, sSubj, sText ) Dim sCC Dim sTo If IsArray( vTo ) Then sTo = Escape( vTo( 0 ) ) sCC = Escape( vTo( 1 ) ) Else sTo = Escape( vTo ) End If IF cApp <> "" Then cApp = DQ( cApp ) & " " sSubj= Escape( sSubj ) sText = Escape( sText ) If IsArray( vTo ) Then sCmd = Subst( "mailto:[1]?subject=[3]&cc=[2]&body=[4]", Array( sTo, sCC, sSubj, sText ) ) Else sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) ) End If On Error Resume Next oShell.Run cApp & sCmd ', 0, True If Err.Number <> 0 Then document.parentwindow.clipboardData.SetData "text", UnEscape( sText ) MsgBox "Windows didn't like the size of message. I've put it on the clipboard" sCmd = Subst( "mailto:[1]?subject=[2]", Array( sTo, sSubj ) ) oShell.Run cApp & sCmd, 0, True HTASleep 5000 End If End Sub

Function RedemptionSend( aRecipients, sSubject, sBody ) dim oSafeItem Dim oItem Dim oApplication Dim oNameSpace Dim sRecip set oSafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem set oApplication = CreateObject("Outlook.Application") set oItem = oApplication.CreateItem(0) 'Create a new message oSafeItem.Item = oItem 'set Item property For Each sRecip In aRecipients If sRecip <> "" Then oSafeItem.Recipients.Add sRecip oSafeItem.Recipients.ResolveAll End If Next oSafeItem.Subject = sSubject oSafeItem.Body = sBody oSafeItem.Send End Function

Function ThunderbirdSend( aRecipients, sSubject, sBody, aAttachments ) 'thunderbird.exe -compose "to='foo@nowhere.net,foo@foo.de',subject=cool page,attachment=file:///c:/temp/foode.txt" Dim sRecip Dim sApp Dim sCmd sRecip = "'" & Join( aRecipients, "," ) & "'" Dim sAttItem Dim sAttach For Each sAttItem in aAttachments If sAttItem <> "" Then sAttItem = Replace(sAttItem, "\", "/" ) sAttach = sAttach & "attachment='file:///" & sAttItem & "'," End If Next If Right( sAttach, 1 ) = "," Then sAttach = Left( sAttach, Len( sAttach ) - 1 ) End If sApp = "C:\Program Files\Mozilla Thunderbird\thunderbird.exe" sCmd = Subst( " -compose ""to=[1],subject=[2],body=[3],[4]""", Array( sRecip, sSubject, sBody, sAttach )) oShell.Run DQ( sApp ) & sCmd, 0, False HTASleep 5000 End Function

A while back Derek Parnell wrote a replacement for Euphoria's print function which would show the structure of arrays. ShowStructure and a support routine AsString make this available to the VBScript programmer. By the way, in case you haven't heard, Euphoria is now open-source!

function ShowStructure( vToShow ) dim nCounter dim sResult dim nArraySize sResult = "" if isarray( vToShow ) then nArraySize = ubound( vToShow ) If nArraySize >= 0 Then for nCounter = 0 to nArraySize - 1 sResult = sResult & ShowStructure( vToShow( nCounter ) ) & "," next sResult = "{" & sResult & ShowStructure( vToShow( nArraySize ) ) & "}" Else sResult = "{}" End If else sResult = AsString( vToShow ) end if ShowStructure = sResult end function Function AsString( x ) Dim sResult If TypeName( x ) = "Null" Then sResult = "Null" Else sResult = CStr( x ) End If AsString = sResult End Function

The output, then, from code such as this:

a = Array(1,Array(2,3,Array("moo"))) wscript.echo showstructure(a)

would be

{1,{2,3,{moo}}}

which maybe leads on toward data serialisation ...

There've been some additions to the file handling space, with the addition of routines to read and write unicode files (ReadFileU, WriteFileU, ReadFirstLineU and its ANSI equivalent, ReadFirstLine.)

Logging has been worked on. It's something I'm unlikely to be totally happy with, but there's now a SetLog and a ClearLog as well as the standard Log (and, given the possibility of confusion with the logarithm system, maybe I should change it to Trace (oh man, how many scripts that would break!))

What else? Well, BuildTree builds a directory tree. FirstLineOf returns the first vbNewLine-delimited line from a string (useful where you've used ReadFile or ReadFileU to inhale an entire file.) LastLineOf does what FirstLineOf does but for the end of the file, and NthLineOf gets you the ... nth ... line.

I've actually forgotten what I wrote UpToAndAfter for, but it's included anyway.

IsOnLine uses the ResolveIP function with the IP address 198.182.196.48 (which points somewhere on linux.org) to see if you are still on line.

SetPriority uses the same code as used in BOOST to set process priority.

StrInArray finds a string in an array of strings, with optional case sensitivity.

StringMap scans a string for the presence of items in one array and swaps them for the equivalently indexed elements in the second array. If the second array is a string, they get swapped for that string.

Doze wraps WSCript.Sleep and HTASleep, so that it can be used in .VBS files and .HTA files.

ModalThing2 shows a modal dialog (only works in .HTA files)

And, finally, SoundMessage:

Sub SoundMessage( sSoundFile, sMessage ) Dim sCommand Dim sFullname sCommand = "sndrec32 /play /close " & DQ( sSoundFile ) oShell.Run sCommand, 0, False Doze 1000 Msgbox sMessage End Sub

Obviously, if you see something that needs to be fixed, fix it. And tell me to fix it so that it can be fixed in the distribution and your name can be added to the list of contributors.

© Copyright Bruce M. Axtens, 2008

[Visual BASIC 6] BOOST (v3)

BOOST got another look-in recently. I had been using it exclusively to do "realtime" and "kill". This particular time I tried to do an "abovenormal" -- instead it did a "kill".

In the process of finding and fixing that bug, I replaced the Collection mechanism with the augmented Collection supplied by the "Class Builder" add-in.

The source code is essentially the same as before but with a few changes. First the SysVars and Var classes. (The comments are predominantly those supplied by the add-in.)

First, SysVars.cls:

'local variable to hold collection Private mCol As Collection Public Function Add(key As String, Optional sKey As String) As Var Dim objNewMember As Var 'create a new object Set objNewMember = New Var 'set the properties passed into the method objNewMember.Value = key objNewMember.key = sKey If Len(sKey) = 0 Then mCol.Add objNewMember Else mCol.Add objNewMember, sKey End If 'return the object created Set Define = objNewMember Set objNewMember = Nothing End Function Public Property Get Item(vntIndexKey As Variant) As Var 'used when referencing an element in the collection 'vntIndexKey contains either the Index or Key to the collection, 'this is why it is declared as a Variant 'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5) Set Item = mCol(vntIndexKey) End Property Public Function Exists(vntIndexKey As Variant) As Boolean Dim V As Var On Error Resume Next Set V = mCol(vntIndexKey) Exists = (Err.Number = 0) End Function Public Function Count() As Long 'used when retrieving the number of elements in the 'collection. Syntax: Debug.Print x.Count Count = mCol.Count End Function Public Sub Remove(vntIndexKey As Variant) 'used when removing an element from the collection 'vntIndexKey contains either the Index or Key, which is why 'it is declared as a Variant 'Syntax: x.Remove(xyz) mCol.Remove vntIndexKey End Sub Public Sub Modify(sValue As String, sKey As String) Dim V As Var 'Set V = New Var Set V = mCol.Item(sKey) V.Value = sValue 'mCol.Remove sKey 'Add sValue, sKey End Sub Public Property Get NewEnum() As IUnknown 'this property allows you to enumerate 'this collection with the For...Each syntax Set NewEnum = mCol.[_NewEnum] End Property Private Sub Class_Initialize() 'creates the collection when this class is created Set mCol = New Collection End Sub Private Sub Class_Terminate() 'destroys collection when this class is terminated Set mCol = Nothing End Sub

Next, Vars.cls (it's tiny but it could hold so much more):

Public key As Variant Public Value As Variant

Now the main module. The first thing that is different here, is that nLevel is now a Long. Integer doesn't handle the ABOVENORMAL_PRIORITY value without complaint.

Next change is removing the reference to Collection, changing it to SysVars and setting up the values.

The benefit of using SysVars and that approach to the Collection object is that we now have an .Exists method, so we now have a tidier way of setting nLevel and trapping invalid settings thereof.

Sub Main() Dim sLevel As String Dim nLevel As Long Dim sProcess As String Dim sCommand As String Dim nInstances As Integer Dim cPrio As New SysVars cPrio.Add KILL_PROCESS, "kill" cPrio.Add LOW_PRIORITY, "low" cPrio.Add BELOWNORMAL_PRIORITY, "belownormal" cPrio.Add NORMAL_PRIORITY, "normal" cPrio.Add ABOVENORMAL_PRIORITY, "abovenormal" cPrio.Add HIGH_PRIORITY, "high" cPrio.Add REALTIME_PRIORITY, "realtime" cPrio.Add KILL_PROCESS, "0" cPrio.Add LOW_PRIORITY, "1" cPrio.Add BELOWNORMAL_PRIORITY, "2" cPrio.Add NORMAL_PRIORITY, "3" cPrio.Add ABOVENORMAL_PRIORITY, "4" cPrio.Add HIGH_PRIORITY, "5" cPrio.Add REALTIME_PRIORITY, "6" Dim aArgs As Variant If Command() = "" Then Syntax End End If aArgs = GetCommandLine(2) sProcess = aArgs(0) sLevel = aArgs(1) If sProcess = "" Or sLevel = "" Then Syntax End End If If cPrio.Exists(sLevel) Then nLevel = Val(cPrio.Item(sLevel).Value) Else ConsoleWrite "Invalid selection of runlevel." & vbNewLine Syntax End End If If nLevel = 0 Then nInstances = KillProcess(sProcess) If nInstances = 0 Then ConsoleWrite "No instances of " & sProcess & " found to kill" & vbNewLine Else ConsoleWrite nInstances & " " & IIf(nInstances > 1, "instances", "instance") & " of " & sProcess & " killed." & vbNewLine End If Else ConsoleWrite sProcess & IIf(SetPriority(sProcess, nLevel), _ " boosted", " NOT boosted") & _ " to priority " & sLevel & " (" & nLevel & ")." & vbNewLine End If End Sub

All the other routines are as before.

I haven't gotten around to extending this tool to do stuff to remote computers. It's not hard; killing a process on another machine means another value for sComputer in KillProcess, and, of course, the relevant privilege level.

© Copyright Bruce M. Axtens, 2008

[Perl] How to do it better

There are some really helpful people in the Perl community. I advertised the original posting on comp.lang.perl.misc and received some very useful responses from John W. Krahn and Michele Dondi, as below.

With respect to the rules, John wrote:

# Rule 1. Remove all 's' sub rule1 { ( my $arg = shift ) =~ tr/s//d; return $arg; } # Rule 2. Sort the characters of the word into alphabetic order sub rule2 { return join '', sort split //, shift; }

John> Why [were] you converting the '|' character and the 'e' character to 'e'?

# Rule 3. Convert all vowels to 'e sub rule3 { ( my $arg = shift ) =~ tr/aiou/e/; return $arg; }

John> The . character class matches a lot more than just letters, or did you really mean "replace any first character except newline with 'n'".

# Rule 4. Replace the first letter with 'n' sub rule4 { ( my $arg = shift ) =~ s/\A[[:alpha:]]/n/; return $arg; }

John> The . character class matches a lot more than just letters.

# Rule 5. Drop the last letter sub rule5 { ( my $arg = shift ) =~ s/[[:alpha:]]\z//; return $arg; } # Rule 6. Replace letter pairs with 'ow' sub rule6 { ( my $arg = shift ) =~ s/([[:lower:]])\1/ow/g; return $arg; }

Then, with respect to the string eval() of each rule, John said, "Ouch! Use a dispatch table instead of string eval()."

my %rule = ( 1 => sub { ( my $arg = shift ) =~ tr/s//d; return $arg; }, 2 => sub { return join '', sort split //, shift; }, 3 => sub { ( my $arg = shift ) =~ tr/aiou/e/; return $arg; }, # more rules here ); # and later on, use rules $res = $rule{ $j }( $arg );

At this point Michele Dondi chipped in with, ">my %rule = (
>  1 => sub {
>    ( my $arg = shift ) =~ tr/s//d;
>    return $arg;
>    },
>  2 => sub {
>    return join '', sort split //, shift;
>    },

Since the keys are numbers, an array may be appropriate."

So there you have it, better rules, anonymous subroutines, and hashes. Powerful stuff.

I wonder how Tcl and the other languages would have done it. Or Protium, for that matter. Any takers?

© Copyright Bruce M. Axtens, 2008

[Perl] How not to do it?

The header for this website says, "Some useful stuff and some examples of how not to do it." This may fall into the latter category.

One of my kids had been playing a computer-based game which used a variety of word puzzles. The question he posed to me was to take a word, apply a small set of rules to it, as many times as necessary, and come up with another word. He would supply the rules and both words, and I would supply the sequence of rule applications which would effect the conversion.

(I'm no guru when it comes to Perl, so if you see something that could be expressed in a more efficient manner, please let me know.)

These are the rules:

1. Remove all 's'

sub rule1 { my $arg = shift; $arg =~ s/s//g; return $arg; }

2. Sort the characters of the word into alphabetic order

sub rule2 { my $arg = shift; my @arr = split( //, $arg ); @arr = sort @arr ; $arg = join( '', @arr ); return $arg; }

3. Convert all vowels to 'e'

sub rule3 { my $arg = shift; $arg =~ s/[a|e|i|o|u]/e/g; return $arg; }

4. Replace the first letter with 'n'

sub rule4 { my $arg = shift; $arg =~ s/^./n/; return $arg; }

5. Drop the last letter

sub rule5 { $arg = shift; $arg =~ s/.$//; return $arg; }

6. Replace letter pairs with 'ow'

sub rule6 { $arg = shift; @arr = split( //, "abcdefghijklmnopqrstuvwxyz" ); for $letter ( @arr ) { $arg =~ s/$letter$letter/"ow"/eg; } return $arg; }

My son then said that the start word was 'first' (or 'ant') and the stop word was 'now'. After some fiddling, resulting in the code below, I said, "With these rules you can't get from 'first' to 'now'. Not even from 'ant' to 'now'. But from 'gnat', yes."

So here's the code, for what it's worth. It was assumed that this would be run as a command line tool, so I load up the start word (stored in $root) and a recursion management flag (stored in $managed). Recursion management is defaulted to true. The recursion level is marked with $level and there's a hash, called %deadends, to keep track of "solutions" that shouldn't be pushed any further as they have already been proved not to get any closer to the solution.

my $root = shift; my $managed = shift; $managed = 1 unless defined($managed); my $level = 0; my %deadends;

Everything else happens in the apply function which looks at every possible combination of rules in pursuit of the target word. After getting the word to check from @_ with shift, a couple of variables are declared and a for loop initiated, stepping through the rules.

sub apply { my $arg = shift; my $res; my $reason; for ( my $j = 1; $j <=6; $j++ ) {

Each rule is evaluated against the passed in value in $arg, and stored in $res. $reason is cleared and each test applied to $res.

$res = eval( "rule$j(\"$arg\")" ); $reason = "";

If $res is the same as $arg, $reason is "equal". If the length of $res is less than 3, $reason is set to "too short". If $managed is 1, and $res is already in the %deadends hash, $reason is set to "deadend", and if $res is equal to "now" (the goal, as it happens) then $reason is set to "found".

if ($res eq $arg) { $reason = "equal"; } elsif ( length( $res ) < 3) { $reason = "too short"; } elsif ($deadends{$res}) { $reason = "deadend" unless $managed eq 0; } elsif ( $res eq "now" ) { $reason = "found"; }

If $reason is not empty and not "equal" then print a newline, as many spaces as there are levels of recursion, the rule that got us here, the incoming word and the result of the rule application. If $reason is "deadend" then print an exclamation mark to show that a deadend has been reached, otherwise print a full stop.

if ( $reason ne "" ) { if ( $reason ne "equal" ) { print "\n"; print " " x $level; print "(R$j) $arg => $res"; if ( $reason eq "deadend" ) { print "!"; } else { print "."; } }

If we've actually reached "now", indicate that with an asterisk. (We could exit the script at this point, but I left it to show all the possible paths to the stop word.)

if ( $res eq "now" ) { print "*"; }

If managing recursion, store the value of $res in the deadends hash.

$deadends{$res}=1 unless $managed eq 0;

Now, if $reason is, for some reason, empty, print a newline, as many spaces as there are recursion levels, the rule, and the $arg and the $res. Then increase the value of $level and recursively call apply with the contents of $res. When it returns, decrease the value of $level.

} else { print "\n"; print " " x $level; print "(R$j) $arg => $res,"; $level++; apply( $res ); $level--; } } }

Here's the first call to apply, with a newline displayed once processing returns from the call.

apply( $root ); print "\n";

Keeping track of dead-ends proved useful. Without it, the 'first' to 'now' attempt generated at 406K file (redirecting the output). With it, I got a 5K file. Similarly, 'ant' to 'now' was 1.8K without, and 457 bytes with. When it came to starting with 'gnat', a managed conversion generated an 8K file. Without management the laptop slowed to a crawl. After about five minutes I got an "Out of memory!" on stderr, so I killed the perl processing resulting in a 902 Megabyte file.

This is the result of a managed attempt with 'ant' as the start word:

(R3) ant => ent, (R4) ent => nnt, (R5) nnt => nn. (R6) nnt => owt, (R2) owt => otw, (R3) otw => etw, (R4) etw => ntw, (R5) ntw => nt. (R5) etw => et. (R4) otw => ntw! (R5) otw => ot. (R3) owt => ewt, (R2) ewt => etw! (R4) ewt => nwt, (R2) nwt => ntw! (R5) nwt => nw. (R5) ewt => ew. (R4) owt => nwt! (R5) owt => ow. (R5) ent => en. (R4) ant => nnt! (R5) ant => an.

Sadly, no asterisks. Next, the log of a managed run starting with 'gnat'. Success came quite quickly: start with 'gnat' and apply rules 2, 3, 4, 2, 4, 5, 6 and 2. An even shorter path appears further down: 3, 4, 2, 5, 6, and 4. The shortest appears to be 4, 2, 5, 6, 4 -- nnat, annt, ann, aow, now.

(R2) gnat => agnt, (R3) agnt => egnt, (R4) egnt => ngnt, (R2) ngnt => gnnt, (R4) gnnt => nnnt, (R5) nnnt => nnn, (R5) nnn => nn. (R6) nnn => own, (R2) own => now.* (R3) own => ewn, (R2) ewn => enw, (R4) enw => nnw, (R5) nnw => nn. (R6) nnw => oow, (R3) oow => eew, (R4) eew => new, (R2) new => enw! (R5) new => ne. (R5) eew => ee. (R6) eew => oow! (R4) oow => now!* (R5) oow => oo. (R5) enw => en. (R4) ewn => nwn, (R2) nwn => nnw! (R5) nwn => nw. (R5) ewn => ew. (R4) own => nwn! (R5) own => ow. (R6) nnnt => ownt, (R2) ownt => notw, (R3) notw => netw, (R2) netw => entw, (R4) entw => nntw, (R5) nntw => nnt, (R5) nnt => nn. (R6) nnt => owt, (R2) owt => otw, (R3) otw => etw, (R4) etw => ntw, (R5) ntw => nt. (R5) etw => et. (R4) otw => ntw! (R5) otw => ot. (R3) owt => ewt, (R2) ewt => etw! (R4) ewt => nwt, (R2) nwt => ntw! (R5) nwt => nw. (R5) ewt => ew. (R4) owt => nwt! (R5) owt => ow. (R6) nntw => owtw, (R2) owtw => otww, (R3) otww => etww, (R4) etww => ntww, (R5) ntww => ntw! (R6) ntww => ntow, (R2) ntow => notw! (R3) ntow => ntew, (R2) ntew => entw! (R5) ntew => nte, (R2) nte => ent, (R4) ent => nnt! (R5) ent => en. (R5) nte => nt. (R5) ntow => nto, (R2) nto => not, (R3) not => net, (R2) net => ent! (R5) net => ne. (R5) not => no. (R3) nto => nte! (R5) nto => nt. (R5) etww => etw! (R6) etww => etow, (R2) etow => eotw, (R3) eotw => eetw, (R4) eetw => netw! (R5) eetw => eet, (R4) eet => net! (R5) eet => ee. (R6) eet => owt! (R6) eetw => owtw! (R4) eotw => notw! (R5) eotw => eot, (R3) eot => eet! (R4) eot => not! (R5) eot => eo. (R3) etow => etew, (R2) etew => eetw! (R4) etew => ntew! (R5) etew => ete, (R2) ete => eet! (R4) ete => nte! (R5) ete => et. (R4) etow => ntow! (R5) etow => eto, (R2) eto => eot! (R3) eto => ete! (R4) eto => nto! (R5) eto => et. (R4) otww => ntww! (R5) otww => otw! (R6) otww => otow, (R2) otow => ootw, (R3) ootw => eetw! (R4) ootw => notw! (R5) ootw => oot, (R3) oot => eet! (R4) oot => not! (R5) oot => oo. (R6) oot => owt! (R6) ootw => owtw! (R3) otow => etew! (R4) otow => ntow! (R5) otow => oto, (R2) oto => oot! (R3) oto => ete! (R4) oto => nto! (R5) oto => ot. (R3) owtw => ewtw, (R2) ewtw => etww! (R4) ewtw => nwtw, (R2) nwtw => ntww! (R5) nwtw => nwt! (R5) ewtw => ewt! (R4) owtw => nwtw! (R5) owtw => owt! (R5) entw => ent! (R5) netw => net! (R5) notw => not! (R3) ownt => ewnt, (R2) ewnt => entw! (R4) ewnt => nwnt, (R2) nwnt => nntw! (R5) nwnt => nwn! (R5) ewnt => ewn! (R4) ownt => nwnt! (R5) ownt => own! (R5) gnnt => gnn, (R4) gnn => nnn! (R5) gnn => gn. (R6) gnn => gow, (R3) gow => gew, (R2) gew => egw, (R4) egw => ngw, (R2) ngw => gnw, (R4) gnw => nnw! (R5) gnw => gn. (R5) ngw => ng. (R5) egw => eg. (R4) gew => new! (R5) gew => ge. (R4) gow => now!* (R5) gow => go. (R6) gnnt => gowt, (R2) gowt => gotw, (R3) gotw => getw, (R2) getw => egtw, (R4) egtw => ngtw, (R2) ngtw => gntw, (R4) gntw => nntw! (R5) gntw => gnt, (R4) gnt => nnt! (R5) gnt => gn. (R5) ngtw => ngt, (R2) ngt => gnt! (R5) ngt => ng. (R5) egtw => egt, (R4) egt => ngt! (R5) egt => eg. (R4) getw => netw! (R5) getw => get, (R2) get => egt! (R4) get => net! (R5) get => ge. (R4) gotw => notw! (R5) gotw => got, (R3) got => get! (R4) got => not! (R5) got => go. (R3) gowt => gewt, (R2) gewt => egtw! (R4) gewt => newt, (R2) newt => entw! (R5) newt => new! (R5) gewt => gew! (R4) gowt => nowt, (R2) nowt => notw! (R3) nowt => newt! (R5) nowt => now!* (R5) gowt => gow! (R5) ngnt => ngn, (R2) ngn => gnn! (R5) ngn => ng. (R5) egnt => egn, (R4) egn => ngn! (R5) egn => eg. (R4) agnt => ngnt! (R5) agnt => agn, (R3) agn => egn! (R4) agn => ngn! (R5) agn => ag. (R3) gnat => gnet, (R2) gnet => egnt! (R4) gnet => nnet, (R2) nnet => ennt, (R4) ennt => nnnt! (R5) ennt => enn, (R4) enn => nnn! (R5) enn => en. (R6) enn => eow, (R3) eow => eew! (R4) eow => now!* (R5) eow => eo. (R6) ennt => eowt, (R2) eowt => eotw! (R3) eowt => eewt, (R2) eewt => eetw! (R4) eewt => newt! (R5) eewt => eew! (R6) eewt => oowt, (R2) oowt => ootw! (R3) oowt => eewt! (R4) oowt => nowt! (R5) oowt => oow! (R4) eowt => nowt! (R5) eowt => eow! (R5) nnet => nne, (R2) nne => enn! (R5) nne => nn. (R6) nne => owe, (R2) owe => eow! (R3) owe => ewe, (R2) ewe => eew! (R4) ewe => nwe, (R2) nwe => enw! (R5) nwe => nw. (R5) ewe => ew. (R4) owe => nwe! (R5) owe => ow. (R6) nnet => owet, (R2) owet => eotw! (R3) owet => ewet, (R2) ewet => eetw! (R4) ewet => nwet, (R2) nwet => entw! (R5) nwet => nwe! (R5) ewet => ewe! (R4) owet => nwet! (R5) owet => owe! (R5) gnet => gne, (R2) gne => egn! (R4) gne => nne! (R5) gne => gn. (R4) gnat => nnat, (R2) nnat => annt, (R3) annt => ennt! (R4) annt => nnnt! (R5) annt => ann, (R3) ann => enn! (R4) ann => nnn! (R5) ann => an. (R6) ann => aow, (R3) aow => eew! (R4) aow => now!* (R5) aow => ao. (R6) annt => aowt, (R2) aowt => aotw, (R3) aotw => eetw! (R4) aotw => notw! (R5) aotw => aot, (R3) aot => eet! (R4) aot => not! (R5) aot => ao. (R3) aowt => eewt! (R4) aowt => nowt! (R5) aowt => aow! (R3) nnat => nnet! (R5) nnat => nna, (R2) nna => ann! (R3) nna => nne! (R5) nna => nn. (R6) nna => owa, (R2) owa => aow! (R3) owa => ewe! (R4) owa => nwa, (R2) nwa => anw, (R3) anw => enw! (R4) anw => nnw! (R5) anw => an. (R3) nwa => nwe! (R5) nwa => nw. (R5) owa => ow. (R6) nnat => owat, (R2) owat => aotw! (R3) owat => ewet! (R4) owat => nwat, (R2) nwat => antw, (R3) antw => entw! (R4) antw => nntw! (R5) antw => ant, (R3) ant => ent! (R4) ant => nnt! (R5) ant => an. (R3) nwat => nwet! (R5) nwat => nwa! (R5) owat => owa! (R5) gnat => gna, (R2) gna => agn! (R3) gna => gne! (R4) gna => nna! (R5) gna => gn.

Writing this makes me wonder if I should have found some way to jump from a successful traversal back to 'gnat' rather than applying the rules to instances of 'now' in search of an extended path to 'now'. I leave that as an exercise to the reader, and if you work out how to do it, please let me know.

© Copyright Bruce M. Axtens, 2008

[Perl/PDK/PerlCtrl] Returning an array of arrays for VB6/VBScript

For the last few weeks I've been trying to get used to working with the Perl Development Kit (PDK 7.1) from ActiveState, particularly PerlCtrl.

One of the challenges I've been facing lately is how to return an array of arrays. That is, returning something that in VB6 or VBScript might be represented as Array( Item, Array( Item, Item ), Item ).

Kudos to Perl Monks, who have provided a function which converts a Perl array to a VB array. Interestingly, it also copes with said converted array being embedded in another array and with that array being converted as well. (Bodes well for other projects.)

So what we have below is some Perl code, a PerlCtrl wrapper around a WMI call to list System Services. The wrapper returns a two element array, the first element being an array of all the services which are running, and the second an array of all the services which have been stopped.

Note that without 'use Win32::OLE qw(in);' you can't access the elements of the $colItems collection, as it enables the use of 'in' in the foreach. Similarly, you need Win32::OLE::Variant for all the Variant() calls.

Please don't ask me to explain what's going on in the convertArrayToVBArray sub, because I have no idea. Anyone know?

package ServicesList; use strict; use warnings; use Win32::OLE qw(in); use Win32::OLE::Variant; sub convertArrayToVBArray { my $array_ref = $_[0]; my $ary = Variant( VT_ARRAY|VT_VARIANT, $#{$array_ref}+1); $ary->Put(\@{$array_ref}); return $ary; } sub GetServices { my @stoppedServices; my @runningServices; my $strComputer = '.'; my $objWMIService = Win32::OLE->GetObject('winmgmts:\\\\' . $strComputer . '\\root\\cimv2'); my $colItems = $objWMIService->ExecQuery('Select * from Win32_Service'); foreach my $objItem (in $colItems) { if ( $objItem->State eq "Stopped" ) { push @stoppedServices, $objItem->DisplayName; } else { push @runningServices, $objItem->DisplayName; } } @stoppedServices = sort @stoppedServices; @runningServices = sort @runningServices; my $running = convertArrayToVBArray( \@runningServices ); my $stopped = convertArrayToVBArray( \@stoppedServices ); my @serviceList = ( $running, $stopped ); my $services = convertArrayToVBArray( \@serviceList ); return $services; } 1; =pod =begin PerlCtrl %TypeLib = ( PackageName => 'ServicesList', TypeLibGUID => '{B20BBC2D-30C6-4DED-ADF2-BADFD66FA221}', # do NOT edit this line ControlGUID => '{B6398FF7-F2BC-42D7-A094-04F53A65941E}', # do NOT edit this line either DispInterfaceIID=> '{9322D169-82A6-46BC-B927-BBAE6E0AC7E9}', # or this one ControlName => 'ServicesList', ControlVer => 1, # increment if new object with same ProgID # create new GUIDs as well ProgID => 'ServicesList.sl', DefaultMethod => '', Methods => { GetServices => { DocString => "Returns array containing two arrays, running services and stopped services respectively.", HelpContext => 101, RetType => VT_ARRAY|VT_VARIANT, TotalParams => 0, NumOptionalParams => 0, ParamList => [], }, }, # end of 'Methods' Properties => { }, # end of 'Properties' ); # end of %TypeLib =end PerlCtrl =cut

The second bit of code is a VBScript testing the COM DLL. It's a assumed that you've run the above code through PerlCtrl, generated a DLL and registered it with RegSvr32.

set o = WScript.CreateObject("ServicesList.sl") a = o.GetServices For Each sServiceName in a(0) wscript.echo "'" & sServiceName & "' running" Next wscript.echo For Each sServiceName in a(1) wscript.echo "'" & sServiceName & "' stopped" Next

I'm having a lot of fun with Perl. I've been able to take a lot of Perl functionality (Tree::Nary, Data::Trie, Lingua::EN::Inflect, Algorithm::LCSS, Algorithm::Knapsack, Algorithm::BinPack, Algorithm::Bucketizer, Algorithm::Permute, Algorithm::SetCovering, String::LCSS and Statistics::Benford) and turn it into something that VB6 and VBScript can use. I'm impressed. Would that every scripting language had this kind of power.

© Copyright Bruce M. Axtens, 2008

[Protium] Master Class #1 (Part 2)

Demonstration - Oblique Strategies

"The Oblique Strategies are a deck of cards. Up until 1996, they were quite easy to describe. They measured about 2-3/4" x 3-3/4". They came in a small black box which said "OBLIQUE STRATEGIES" on one of the top's long sides and "BRIAN ENO/PETER SCHMIDT" on the other side. The cards were solid black on one side, and had the aphorisms printed in a 10-point sans serif face on the other.

...

The deck itself had its origins in the discovery by Brian Eno that both he and his friend Peter Schmidt ... tended to keep a set of basic working principles which guided them through the kinds of moments of pressure — either working through a heavy painting session or watching the clock tick while you're running up a big buck studio bill. Both Schmidt and Eno realized that the pressures of time tended to steer them away from the ways of thinking they found most productive when the pressure was off. The Strategies were, then, a way to remind themselves of those habits of thinking — to jog the mind."         
-- Oblique Strategies

A web-based installation of Oblique Strategies is supplied in the standard Protium install. Using the "Internet Information Services" snap-in, create a virtual directory pointing to C:\protium\Code\prx\os. Specify its default as index.prx, call it 'os', and share the C:\protium\Code\prx\os directory (Microsoft Access is picky about being able to write to databases even when only reading.)

Further information on setting up IIS can be found in the Protium document "C:\protium\bin\plugins\Configuring Windows IIS 5 to use with Protium and Isis.html"

The Protium code in the index.prx file is as follows:

<@ DEFKEYLIT>__Transput|__HTMLTransput</@> <@ SAYPRO></@> <@ SAYDOC> <@ SAYDHD> <@ SAYDTT>Oblique strategies</@> </@> <@ SAYDBD> <@ DEFDBFLIT>os</@> <@ DEFRSTCAP>select * from os where cardid = <@ SAYRANLIT>100</@></@> <@ SAYDPR>Oblique strategy: <@ SAYFLD>message</@></@> </@> </@>

The above code (indented only to more clearly demonstrate document structure) outputs a different strategy each time the page is refreshed. The syllables translate as follows:

<@ DEFKEYLIT>__Transput|__HTMLTransput</@>	define the Transput as HTML
<@ SAYPRO>	output a document prologue. (What is output by the PRO syllable depends on the Transput defined, as is the case for all document related syllables.)
<@ SAYDOC>	Enclose a document.
<@ SAYDHD>	Enclose a document header, in the context of an existing document.
<@ SAYDTT>Oblique strategies</@>	set the document title, in the context of an existing document body and header.
<@ SAYDBD></@>	enclose a document body, in the context of an existing document.
<@ DEFDBFLIT>os</@>	opens this data source, by default a JET/MSAccess database.
<@ DEFRSTCAP>select * from os where cardid = <@ SAYRANLIT>100</@></@>	Open record source defined by captured output.
<@ SAYRANLIT>100</@>	return a random number between 1 and 100.
<@ SAYDPR></@>	enclose a document paragraph, in the context of the existing document.
<@ SAYFLD>message</@>	print the contents of the field called 'message' which, in this context, is part of the 'os' recordset.

Note that the code chooses a strategy based on a random number between 1 and 100. But what if there are more than 100 strategies? Wouldn't it be better if the actual number of records could be found and that used as the basis for the RAN syllable? Two ways of handling this requirement are described below:

<@ DEFKEYLIT>__Transput|__HTMLTransput</@> <@ SAYPRO></@> <@ SAYDOC> <@ SAYDHD> <@ SAYDTT>Oblique strategies</@> </@> <@ SAYDBD> <@ DEFDBFLIT>os</@> <@ DEFRSTLIT>os</@> <@ LETVARSZERST>upper|___</@> <@ DEFRSTCAP>select * from os where cardid = <@ SAYRANVAR>upper</@></@> <@ SAYDPR>Oblique strategy: <@ SAYFLD>message</@></@> </@> </@>

The changed syllables translate as follows:

<@ DEFRSTLIT>os</@>	Select every record in the database.
<@ LETVARSZERST>upper|___</@>	assign to the variable 'upper' the size of the default (marked by three underscores) recordset.
<@ RSTCAP>select * from os where cardid = <@ SAYRANVAR>upper</@></@>	Select a new recordset, capturing the output from RAN but using the variable 'upper' to specify the limit.

<@ DEFKEYLIT>__Transput|__HTMLTransput</@> <@ SAYPRO></@> <@ SAYDOC> <@ SAYDHD> <@ SAYDTT>Oblique strategies</@> </@> <@ SAYDBD> <@ DEFDBFLIT>os</@> <@ DEFRSTLIT>os</@> <@ ACTMOVRANRST></@> <@ SAYDPR>Oblique strategy: <@ SAYFLD>message</@></@> </@> </@>

Rather than get the number of records, simply ...

<@ ACTMOVRANRST></@>

move the record pointer to a random place in the recordset.

This demonstrates the power of idiomatic Protium: short, sweet and to the point.

Questions and Answers

I can't see a main() anywhere. Where's the start?

Protium implements a single-pass code evaluation model. This is quite unlike most other languages which implement double-pass code evaluation: first pass to discover and make a map; second pass to evaluate.

Protium starts at the beginning of a named file, and builds its awareness of context from there. Because of this approach, we may never examine code we aren't interested in.

I keep using the same construction over and over again. Is there a way of abbreviating Protium words?

What you can do is create a compound operator (a concept borrowed from OPS-3). These are defined using the KOP syllable. If you wanted to define LVK as a shorthand for LETVARKEY, for example, then you would code

<@ DEFKOPLIT>LVK|LETVARKEY</@>

Thereafter you would be able to use the abbreviated form, replacing code like

<@ LETVARKEY>MyGuid|__GUID</@>

with

<@ LVK>MyGuid|__GUID</@>

There are other ways of doing this, including UDS (user-defined syllable) and BLK (code block), but this is by far the simplest.

*** End of Part 2 ***

© Copyright Bruce M. Axtens, 2008

[Protium] Master Class #1 (Part 1)

Protium is ...

Protium is essentially, and at heart, a way of finding data in a myriad of locations in a homologous manner, manipulating it in a myriad of ways, and then delivering it to a myriad of displays, in a myriad of [human] languages. A concomitant of that is that data be current, so this also involves updating old data, which means that a similar potential is there for making changes to data.

But the overriding maxim is for a direct equivalence of task to operator at the conceptual level. This means that high-level / low-level language distinctions don't enter in: branching is a single operator, but so is "work out the utility matrix for this complex set of possibilities"; the iteration syllable is at the same level as that of add and of unique-sort.

Influences

"I had as a goal the economy and power of APL (minus the cryptic nature) while having the manipulation power of SNOBOL, the one-for-one power of multimedia-instruction-set assembler (e.g. QUEXAL), the task oriented nature of NODAL, the reality representation characteristics of ATLAS, and the data ordering capabilities of the 'lost languages' (Simscript, Dectab, dBase etc.), [such that] the data is available in a way that ordinary programming languages don't permit.

"The other thing I took from NODAL was JOSS's implicit mixing of code and data, which is much saner than LISP's, and also the way that there was an implicit hierachy of data.

"I also borrowed some control structures from RPG, temporary constructions from Miranda, generators from Icon, multiple outcomes from COMIT and compound operators from OPS-3.

"I rejected the naive form of IO (which bedevilled Algol and Fortran). I think the ability to display is the least-used functionality of programming, only touched on in screenwiping and SOAP.

"The idea of assignment [in most programming languages] is generally also naive - for instance the fact that it is a function has been overblown in functional languages, but ignored elsewhere. So [I implemented] scaling and multiple returns (present in LYaPAS in 1964), multiple assigns (common in FORTRAN, APL and the original BASIC), multiple functional transforms (common in any DSP language, e.g. Faust) as well as the closer knitting of data and code (from FORTRAN and dBase).

"The final point to note is that the entirety of Protium works with a SNOBOL-/COMIT-style success/failure flag, converted to a success / failure / don't-know ternary system. Any operation will set this, but it can be qualified (success, found, quantity more than zero, test type, pattern match, etc.)

"Essentially, the idea was to revisit the nature of the programming task, and learn from where the bounds had been stretched; to try to get a thought-to-line-of-code transference capability, rather than the reductive, ALGOL-ish, 'see-how-small-I-can-get-the-core' approach."

        -- Diarmuid Pigott, personal correspondence, 9 January 2007.

How to Program in Protium

The overall Protium approach to programming is to work out what you want to do, then work out what it is that that would be in Protium terms. Sometimes this is very similar to the conventional way (most of the code examples are conventional in that way to secure familiarity). Sometimes it involves a simple task that is unfamiliar in those terms.

Unlike most other programming languages, Protium does not force the programmer to work in either a top-down / decompositional or bottom-up / compositional way. Either approach can be taken. The art of Protium is in the discovery of the idiomatic form which best describes the solution to the problem.

Workflow in Protium programming is simply this: work out what data you need to solve a problem, then extract it and present it. When there is need to extract data according to a criterion, it is specified in two stages, first the data source, then the record source, in the following hierarchy: Data Source -> Record Source -> Record -> Field -> Subfield. Any number of Data Sources can be open at one time, and any number of Record Sources, but a Record Source will always be subordinate to its Data Source.

Protium supports a number of ways of addressing and participating in memory. Memory is untyped. It is a simple tuple of name => value (read name implies value) which can be late-bind typed using 'typifiers', but is inherently capable of any interpretation. There is one global memory space, but it is lexically divided (using namespaces) to make the equivalents of local, static etc. Memory is synthetic, in that it will create a variable (or a structure) on being first called — variables do not need to be declared nor the type of their content specified.

Protium relies heavily on the concept of aliases: when any complex computational task is invoked the operation is aliased, so that you can switch back to it at any time. Anything can be aliased: branching, looping, switching, creation and use of structures, and interaction with data. These aliases, also known as workareas, have two components: a type and a name.

Alias names can be invoked internally, so a field called 'ChinaCollection => DateOfPurchase' will automatically invoke the aliased workspace called ChinaCollection to fulfil the data request. This means that some very powerful manipulations are possible - such as the much-used scatter/gather (borrowed from FoxPro) to swap data between aliased workspaces.

Implicit in all of this is the idea that, where possible, everything should be invokable with one operator, so DCT (dictionary) without a name is the dictionary currently in scope, and of course implicit in the entire thing is a hierarchy of context - the field is always (unless specified) invoked in the context of the current record or the current recordset (or query or view) of the current database. It is this dependence on context - Protium's context-aware, rather than context-free, grammar - which trips up the beginning Protium programmer. That and the lack of appropriate casting of numerics - all comparisons in Protium are lexical (i.e. 'a' is less than 'c'; 5 is greater than 45000), so comparison syllables must bear an explicit number-cast syllable when a numeric comparison is required.

Conventions

Protium respects the following naming conventions with respect to the file type:

Extension	Meaning
.p	a Protium script in plain text format
.pr	a Protium script in rich text format (RTF)
.pre	a ProtiumWeb script (plain text, HTML or rich text)
.prx	a Protium executable project (plain text, HTML or rich text)
.plb	a Protium library (plain text, HTML or rich text)

The code in a .pre or .prx file can favour HTML (the <BODY>text</BODY> approach) or favour Protium (the <@ SAYDBDLIT>text</@> approach). In the latter it is possible to write <@ DBD>text</@> as Protium will disambiguate where possible, making 'slang' forms possible .

Generally we make two files per website, a default.prx and an index.prx, but of course it could be set up to look for an index.pre, if necessary.

*** End of Part One ***

© Copyright Bruce M. Axtens, 2008

[FORTRAN] Making a DLL for VB6

As a break from trying to figure out how to get a pattern matching library DLLified (and UTF-32 sensitive), my boss gave me something else to do, something on the one hand similar (wrap something in a DLL) and on the other quite different (wrap two knapsack algorithms done in Fortran 90).

The knapsack code is derived from

Algorithm 4.9, Donald Kreher and Douglas Stinson, Combinatorial Algorithms, CRC Press, 1999, page 125.

and was downloaded from FORTRAN Source Codes, specifically, the COMBO library. Many thanks to John Burkardt for making this resources available.

The files used from the COMBO library were knapsack_01.f90, knapsack_rational.f90, knapsack_reorder.f90, rvec_backtrack.f90 and r_swap.f90, and were compiled using Compaq Visual Fortran.

Seeing as CVF is no longer available (except perhaps on eBay) you might get away with the Intel® Fortran Compiler for Windows, SilverFrost's FTN95 or g95.

Don't try it with Watcom Fortran, however, because that only does Fortran 77. Mind you, if the algorithms you're wrapping are F77 ones from NIST's 'Dictionary of Algorithms and Data Structures' or Steven Skiena's The Stony Brook Algorithm Repository you may do okay with the Watcom offering or even GNU's g77.

I really like Fortran. I remember writing some VAX-11 FORTRAN back in 1983 (along with a bit more VAX-11 COBOL) and found it quite powerful and expressive. I know that there's been a fairly widespread pooh-pooh-ing of Fortran in recent years, but I try not to be influenced by peer-group pressure, preferring to actually see for myself whether a language is any good or not.

Okay, off the soap box and down to the code. I'm not going to bother posting all the COMBO code, just what I wrote to wrap it.

These are the three exposed routines and have essentially the same framework: a subroutine header, two declarations controlling symbol names and method of access, the call to the COMBO routine, the return and the end of subroutine. Really, really, simple. Gobsmackingly simple, compared to some other languages I could mention. Rather embarrasing really ... so little to show.

If you're wondering why I explicitly state that the parameters are being passed by reference (!dec$ attributes reference ...), it's because a side effect of specifying "stdcall" is that it forces the passing mechanism into pass-by-value, and in this case, quite a few of the parameters are being modified by the subroutine.

!BOAL0.f90 !FUNCTIONS/SUBROUTINES exported from BOAL0.dll: !stdcall forces all parameters to pass-by-value, !thus the 'attributes reference' declaration subroutine Knapsack01( n, mass_limit, p, w, x, mass, profit ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "Knapsack01" :: Knapsack01 !dec$ attributes reference :: n, mass_limit, p, w, x, mass, profit call knapsack_01 ( n, mass_limit, p, w, x, mass, profit ) return end subroutine Knapsack01 subroutine KnapsackRational ( n, mass_limit, p, w, x, mass, profit ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "KnapsackRational" :: KnapsackRational !dec$ attributes reference :: n, mass_limit, p, w, x, mass, profit call knapsack_rational ( n, mass_limit, p, w, x, mass, profit ) return end subroutine KnapsackRational subroutine KnapsackReorder ( n, p, w ) !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, ALIAS : "KnapsackReorder" :: KnapsackReorder !dec$ attributes reference :: n, p, w call knapsack_reorder ( n, p, w ) return end subroutine KnapsackReorder

The other routines are linked in during the compile and I end up with a nice little .DLL.

Okay, so maybe there's something more to show on the VB6 side.

First off, the declares. VB6 defaults to pass-by-reference, thus the missing "ByRef" ahead of each parameter.

Declare Sub KnapsackReorder Lib "BOAL0.dll" (n As Integer, p As Single, w As Single) Declare Sub Knapsack01 Lib "BOAL0.dll" (n As Integer, mass_limit As Single, p As Single, w As Single, x As Single, mass As Single, profit As Single) Declare Sub KnapsackRational Lib "BOAL0.dll" (n As Integer, mass_limit As Single, p As Single, w As Single, x As Single, mass As Single, profit As Single)

Next the test code which is derived from TEST094 and TEST095 found inside COMBO's combo_prb.f90.

Do note that the floating point variables are defined here as Single. This seems to be the best match to an undecorated Fortran REAL. Maybe if I'd tweaked the COMBO code to REAL*8, I could have used Double on the VB6 side.

Sub main() Dim i As Integer Dim mass As Single Const mass_limit As Single = 26# Dim p(4) As Single Dim profit As Single Dim w(4) As Single Dim x(4) As Single Const n As Integer = 4 p(0) = 24# p(1) = 13# p(2) = 23# p(3) = 15# p(4) = 16# w(0) = 12# w(1) = 7# w(2) = 11# w(3) = 8# w(4) = 9# Debug.Print " " Debug.Print "TEST094" Debug.Print " KNAPSACK_REORDER reorders the knapsack data." Debug.Print " KNAPSACK_01 solves the 0/1 knapsack problem." Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next KnapsackReorder n, p(0), w(0) Debug.Print " " Debug.Print " After reordering by Profit Density:" Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next Debug.Print " " Debug.Print " Total mass restriction is " & mass_limit Knapsack01 n, mass_limit, p(0), w(0), x(0), mass, profit Debug.Print " " Debug.Print "Object", "Density", "Choice", "Profit", "Mass" Debug.Print " " For i = 0 To n Debug.Print i, p(i) / w(i), x(i), x(i) * p(i), x(i) * w(i) Next Debug.Print " " Debug.Print " Total:", , , profit, mass '-- p(0) = 24# p(1) = 13# p(2) = 23# p(3) = 15# p(4) = 16# w(0) = 12# w(1) = 7# w(2) = 11# w(3) = 8# w(4) = 9# Debug.Print " " Debug.Print "TEST094" Debug.Print " KNAPSACK_REORDER reorders the knapsack data." Debug.Print " KNAPSACK_RATIONAL solves the rational knapsack problem." Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next KnapsackReorder n, p(0), w(0) Debug.Print " " Debug.Print " After reordering by Profit Density:" Debug.Print " " Debug.Print "Object", "Profit", "Mass", "Profit Density" Debug.Print " " For i = 0 To n Debug.Print i, p(i), w(i), p(i) / w(i) Next Debug.Print " " Debug.Print " Total mass restriction is " & mass_limit KnapsackRational n, mass_limit, p(0), w(0), x(0), mass, profit Debug.Print " " Debug.Print "Object", "Density", "Choice", "Profit", "Mass" Debug.Print " " For i = 0 To n Debug.Print i, p(i) / w(i), x(i), x(i) * p(i), x(i) * w(i) Next Debug.Print " " Debug.Print " Total:", , , profit, mass End Sub

Hmm ... nothing much amazing there either. But that's how it was with wrapping the Fortran. Simple and powerful at the same time. So far as I'm concerned, if we ever have to rewrite Protium, Fortran's going to be very near the top of the list.

© Copyright Bruce M. Axtens., 2007

[Visual BASIC 6] BOOST (v2)

I revisited BOOST this week. A friend had pointed out to me some time back that /P: and /L: were a bit of a pain when one wanted to speed something up quickly, or kill it quickly. So this version changes the command line handling.

This version also demonstrates how to kill a process. In fact it kills every process of the same name. I wish I'd had this a couple of years ago when I was doing stuff with Excel -- I'd end up with multiple Excel sessions which I would then have to kill off one-by-one through the Task Manager. (I eventually ended up installing Cygwin so that I could script the process.)

If you remember the original VBScript of BOOST and the first VB6 version, you'll see some similarities.

I've given up on using setsubsys in favour of using VBAdvance (which is now freeware) to handle the compile-to-console-app process. I'm still compressing the app using UPX.

First a few constants and the declarations, found on vb.mvps.org, for doing console I/O.

Option Explicit Const KILL_PROCESS = 0 '0 Const LOW_PRIORITY = 64 '1 Const BELOWNORMAL_PRIORITY = 16384 '2 Const NORMAL_PRIORITY = 32 '3 Const ABOVENORMAL_PRIORITY = 32768 '4 Const HIGH_PRIORITY = 256 '5 Const REALTIME_PRIORITY = 128 '6 Private Declare Function GetStdOutHandle Lib "kernel32" _ Alias "GetStdHandle" _ (Optional ByVal HandleType As Long = -11) As Long Private Declare Function WriteFile Lib "kernel32" _ (ByVal hFile As Long, _ ByVal lpBuffer As String, _ ByVal cToWrite As Long, _ ByRef cWritten As Long, _ Optional ByVal lpOverlapped As Long) As Long 'To keep things simple, wrap these two APIs in a single helper function like so: Private Function ConsoleWrite(sText As String) As Long WriteFile GetStdOutHandle, ByVal sText, Len(sText), ConsoleWrite End Function

Next, a few supporting functions. First off the rank, is an invocation syntax display. Notice that priority can now be specified either by a number (0 to kill, 1-6 for low to realtime) or by name (kill, low, belownormal, normal, abovenormal, high, realtime).

Sub Syntax() ConsoleWrite ("Syntax:" & vbNewLine & _ vbTab & "Boost {processname} {runlevel}" & vbNewLine & _ "Run level as number:" & vbNewLine & _ vbTab & "0 = KILL_PROCESS" & vbNewLine & _ vbTab & "1 = LOW_PRIORITY" & vbNewLine & _ vbTab & "2 = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "3 = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "4 = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "5 = HIGH_PRIORITY" & vbNewLine & _ vbTab & "6 = REALTIME_PRIORITY" & vbNewLine & vbNewLine & vbNewLine & _ "Run level as text:" & vbNewLine & _ vbTab & "kill = KILL_PROCESS" & vbNewLine & _ vbTab & "low = LOW_PRIORITY" & vbNewLine & _ vbTab & "belownormal = BELOWNORMAL_PRIORITY" & vbNewLine & _ vbTab & "normal = NORMAL_PRIORITY" & vbNewLine & _ vbTab & "abovenormal = ABOVENORMAL_PRIORITY" & vbNewLine & _ vbTab & "high = HIGH_PRIORITY" & vbNewLine & _ vbTab & "realtime = REALTIME_PRIORITY" & vbNewLine) End Sub

Second, the command line parser. This splits on space and tab and is based on code found at microsoft.public.vb.winapi

Function GetCommandLine(Optional MaxArgs) As Variant 'Declare variables. Dim C As String Dim CmdLine As String Dim CmdLnLen As Integer Dim InArg As Boolean Dim i As Integer Dim NumArgs As Integer Dim ArgArray As Variant 'See if MaxArgs was provided. If IsMissing(MaxArgs) Then MaxArgs = 10 'Make array of the correct size. ReDim ArgArray(MaxArgs - 1) NumArgs = 0: InArg = False 'Get command line arguments. CmdLine = Command() CmdLnLen = Len(CmdLine) 'Go thru command line one character 'at a time. For i = 1 To CmdLnLen C = Mid(CmdLine, i, 1) 'Test for space or tab. If (C <> " " And C <> vbTab) Then 'Neither space nor tab. 'Test if already in argument. If Not InArg Then 'New argument begins. 'Test for too many arguments. If NumArgs = MaxArgs Then Exit For NumArgs = NumArgs + 1 InArg = True End If 'Concatenate character to current argument. ArgArray(NumArgs - 1) = ArgArray(NumArgs - 1) & C Else 'Found a space or tab. 'Set InArg flag to False. InArg = False End If Next i 'Resize array just enough to hold arguments. ReDim Preserve ArgArray(NumArgs - 1) 'Return Array in Function name. GetCommandLine = ArgArray '() End Function

Third, the two routines which wrap the WMI functions to set priority and to kill process. The latter was found at tek-tips. If I remember correctly, the places in each routine where it says

sComputer = "."

could, in fact, have some other computer's name. If you had sufficient privilege you could be tweaking or killing a process on someone else's machine.

Function SetPriority(sProcess As String, nPriority As Integer) As Boolean Dim sComputer As String Dim oWMIService As Object Dim cProcesses As Object Dim oProcess As Object Dim bDone As Boolean bDone = False sComputer = "." Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2") On Error Resume Next Set cProcesses = oWMIService.ExecQuery _ ("Select * from Win32_Process Where Name = '" & sProcess & "'") For Each oProcess In cProcesses oProcess.SetPriority (nPriority) If Err.Number <> 0 Then GoTo DoNext End If bDone = True DoNext: Next On Error GoTo 0 SetPriority = bDone End Function Function KillProcess(sProcess As String) As Integer Dim oWMIService As Object Dim sComputer As String Dim oProcess As Object Dim nDone As Integer nDone = 0 sComputer = "." 'this computer Set oWMIService = GetObject("winmgmts:") For Each oProcess In oWMIService.InstancesOf("Win32_process") If LCase(oProcess.Name) = LCase(sProcess) Then oProcess.Terminate nDone = nDone + 1 End If Next KillProcess = nDone End Function

Finally, the Main subroutine. Notice the additions to the priorities collection. Note also the change in the way the command line is handled.

Because there's no .Exists method on Collections, the .Item call is wrapped in an 'On Error' so that a non-existent item situation is caught appropriately.

Sub Main() Dim sLevel As String Dim nLevel As Integer Dim sProcess As String Dim sCommand As String Dim nInstances As Integer Dim dPriorities As New Collection dPriorities.Add Item:=KILL_PROCESS, Key:="kill" dPriorities.Add Item:=LOW_PRIORITY, Key:="low" dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="belownormal" dPriorities.Add Item:=NORMAL_PRIORITY, Key:="normal" dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="abovenormal" dPriorities.Add Item:=HIGH_PRIORITY, Key:="high" dPriorities.Add Item:=REALTIME_PRIORITY, Key:="realtime" dPriorities.Add Item:=KILL_PROCESS, Key:="0" dPriorities.Add Item:=LOW_PRIORITY, Key:="1" dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="2" dPriorities.Add Item:=NORMAL_PRIORITY, Key:="3" dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="4" dPriorities.Add Item:=HIGH_PRIORITY, Key:="5" dPriorities.Add Item:=REALTIME_PRIORITY, Key:="6" Dim aArgs As Variant If Command() = "" Then Syntax End End If aArgs = GetCommandLine(2) sProcess = aArgs(0) sLevel = aArgs(1) If sProcess = "" Or sLevel = "" Then Syntax End End If On Error Resume Next nLevel = dPriorities.Item(sLevel) If Err.Number = 5 Then ConsoleWrite "Invalid selection of runlevel." & vbNewLine Syntax End End If On Error GoTo 0 If nLevel = 0 Then nInstances = KillProcess(sProcess) If nInstances = 0 Then ConsoleWrite "No instances of " & sProcess & " found to kill" & vbNewLine Else ConsoleWrite nInstances & " " & IIf(nInstances > 1, "instances", "instance") & " of " & sProcess & " killed." & vbNewLine End If Else ConsoleWrite sProcess & IIf(SetPriority(sProcess, nLevel), _ " boosted", " NOT boosted") & _ " to priority " & sLevel & " (" & nLevel & ")." & vbNewLine End If End Sub

What's next with this thing? I suppose one could explore the possibility of influencing the lives of applications on other computers:

BOOST Skype.exe kill /C:GUEST_01

There's also the fact that the commandline parser doesn't properly handle double-quoted names. If an .exe had a space it its name, you wouldn't be able use BOOST on it.

Finally, here's a short batch file (killall.bat) I use for killing applications en masse. It was originally designed to get around the 'typing the /P and /L' issue, but I'm so used to using it now ...

@echo off :loop if %1@==@ goto done c:\bin\boost %1 kill shift goto loop :done

An example invocation:

killall excel.exe outlook.exe

© Copyright Bruce M. Axtens, 2007

[Programming] Okay, Ignorance is Bliss ...

If by Ignorance you mean an implementation of the Bliss programming language, then yes, Ignorance is Bliss.

After two and half weeks of Ada, I had to have a break. I wandered over to the Retrocomputing Museum and downloaded the Ignorance source code. While I was at it I also downloaded the source for CUPL, the Cornell University Programming Language. Interestingly, the same interpreter also works for CORC, the CORnell Compiler. The man behind the website, Eric Raymond, has the following, less than flattering, words to describe CUPL:

"Another hideous old design, CUPL — Cornell University Programming Language. It looks something like a really archaic BASIC with linear-algebra builtins."

And what's wrong with BASIC and linear algebra? (That was a rhetorical question.)

I've been able to get CUPL to work, but haven't had any success with Ignorance. Or, for that matter, with JOSS.

To find out more about these languages, HOPL is your friend: Bliss, CUPL and JOSS.

as is Wikipedia: Bliss, CORC (CUPL precursor) and JOSS.

© Copyright Bruce M. Axtens., 2007

[Ada (GNAT)] Who said, "Ignorance is bliss"?

Ignorance isn't bliss. For the past two days I've been trying to do what I expect an Ada freak could do in 2 minutes. It's been a very frustrating, sleep-depriving process.

After trying to do amazing things with GNAT.Spitbol, I'm now trying to do the same to Dr. Dmitry A. Kazakov's match library. And, as usual, it has not been an easy journey.

UTF-32 aside for now, I've been trying this week simply to make the Matching and Pattern packages available to the Windows programmer via the DLL mechanism.

At this point, all I have is a wrapper for the match() function.

I really hope there is an easier way of doing this. As I've said a few times before, I'm a newbie when it comes to Ada but have been forced to jump into the deep end of the pool. Please, if you know a better way, tell me!!

Oh, and I should point out that, though it seems I'm passing the right stuff to match(), in its current form the VB6 code keeps receiving an error code from the Matching package. It may be because I'm not declaring the pattern properly.

Okay, to the code. First up, the BOS.ADS spec file:

--bos.ads with GNAT.Spitbol; use GNAT.Spitbol; with Interfaces.C; use Interfaces.C; with Interfaces.C.Strings; use Interfaces.C.Strings; with Win32; use Win32; package BOS is procedure Initialize_API; procedure Finalize_API; function pmatch( pLength : Win32.LONG; pString : Win32.LONG; pPointer : Win32.LONG; pPattern : Win32.LONG ) return Win32.LONG; private pragma Export (DLL, Initialize_API ); pragma Export (DLL, Finalize_API ); pragma Export (DLL, pmatch ); end BOS;

Next, the body (BOS.ADB). There are lots of Put calls in here for debugging. These are what appear if you run the VB6 code as a console app.

-- BOS.ADB with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Bounded; use Ada.Strings.Bounded; with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; with Interfaces.C; use Interfaces.C; with Interfaces.C.Strings; use Interfaces.C.Strings; with System; with Unchecked_Conversion; with Win32; use Win32; with Win32.Winbase; use Win32.Winbase; with Matching; use Matching; with Patterns; use PAtterns; package body BOS is type VBLong is record L : Win32.LONG; end record; type PointerToVBLong is access VBLong; type Access_Int is access Interfaces.C.int; function Long_To_Pointer is new Unchecked_Conversion (Win32.LONG, PointerToVBLong ); function Long_To_Access_Int is new Unchecked_Conversion (Win32.LONG, Access_Int ); function Long_To_CharsPtr is new Unchecked_Conversion (Win32.LONG, chars_ptr ); PVBLong : PointerToVBLong; PVBString : chars_ptr; function pmatch( pLength : Win32.LONG; pString : Win32.LONG; pPointer : Win32.LONG; pPattern : Win32.LONG ) return Win32.LONG is iLength : Interfaces.C.int; piPointer : Access_Int; uString : unBounded_String; uPattern : unBounded_String; res : StatusCode; begin PVBLong := Long_to_Pointer( pLength ); iLength := Interfaces.C.int( PVBLong.all.L ); Put( "iLength=" ); Put( Integer(iLength), 10, 10 ); Put_Line( "" ); piPointer := Long_To_Access_Int( pPointer ); Put( "@piPointer=" ); Put( Integer( piPointer.all ), 10, 10); Put_Line( "" ); piPointer.all := 1; Set_unBounded_String( uString, Value( Long_To_CharsPtr( pString ) ) ); Set_unBounded_String( uPattern, Value( Long_To_CharsPtr( pPattern ) ) ); Put_Line( "String=" & To_String( uString ) ); Put_Line( "Pattern=" & To_String( uPattern ) ); res := match( iLength, To_C( To_String( uString ) ), piPointer, To_C( To_String( uPattern ) ) ); Put( "@piPointer=" ); Put( Integer( piPointer.all ), 10, 10); Put_Line( "" ); Put( "@res=" ); Put( Integer( res ), 10, 10); Put_Line( "" ); return Win32.LONG( res ); end pmatch; procedure Initialize_API is procedure Adainit; pragma Import (C, Adainit); begin Adainit; end Initialize_API; procedure Finalize_API is procedure Adafinal; pragma Import (C, Adafinal); begin Adafinal; end Finalize_API; end BOS;

For the sake of completeness, BOS.DEF, BUILD.GPR and BUILD.BAT. Note that in BUILD.BAT, I specify match\match.o as an object file for gnatlink.

EXPORTS initialize_api finalize_api pmatch

project Build is for Source_Dirs use ( "./", "./match", "c:\mingw\lib\gcc\mingw32\4.2.1\**" ); for Object_Dir use "debug"; for Exec_Dir use "debug"; for Main use ("bos"); type Style_Type is ("debug", "release"); Style : Style_Type := external ("STYLE", "debug"); case Style is when "debug" => for Object_Dir use "debug"; when "release" => for Object_Dir use "release"; for Exec_Dir use "."; end case; package Builder is case Style is when "debug" => for Default_Switches ("Ada") use ("-g"); when others => null; end case; end Builder; package Binder is case Style is when "debug" => for Default_Switches ("Ada") use ("-E"); when others => null; end case; end Binder; package Compiler is case Style is when "debug" => for Default_Switches ("Ada") use ( "-s", "-gnato", "-fstack-check", "-g", "-gnat05"); --gnata when "release" => for Default_Switches ("Ada") use ("-O2", "-fno-strict-aliasing", "-gnato", "-gnat05"); end case; end Compiler; end Build;

@echo off setlocal SET C_INCLUDE_PATH=C:\MinGW\lib\gcc\mingw32\4.2.1 set target=%1 if %1@==@ set target=debug if not %1@==debug@ if not %1@==release@ set target=debug echo Building %target% version of dll c:\mingw\bin\gnat make -Pbuild -XSTYLE=%target% -LC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada if errorlevel 1 goto done c:\mingw\bin\gnatbind -n -x %target%\bos.ali -IC:\MinGW\lib\gcc\mingw32\4.2.1\stdarg -IC:\MinGW\lib\gcc\mingw32\4.2.1\win32ada if errorlevel 1 goto done c:\mingw\bin\gnatlink -g -mdll -s -o %target%\bos.dll %target%\bos.ali -Xlinker --base-file=%target%\bos.base match\match.o if errorlevel 1 goto done c:\mingw\bin\dlltool --dllname bos.dll --base-file %target%\bos.base --output-exp %target%\bos.exp --def bos.def if errorlevel 1 goto done c:\mingw\bin\gnatlink -g -mdll -s -o %target%\bos.dll %target%\bos.ali -Xlinker --base-file=%target%\bos.base %target%\bos.exp --enable-stdcall-fixup match\match.o if errorlevel 1 goto done if %target%==release upx -9 %target%\bos.dll :done

Finally, the VB6 code being used to test it all. Please note that I'm using SetSubSys to turn the resulting EXE into a Console application. If you don't do that, the output from Ada's Put() statements will not be made visible.

It's not pretty code, but it does the job. By the way, if you don't do the StrConv, you'll be passing UTF-16 strings.

Declare Sub initialize_api Lib "debug\bos.dll" () Declare Sub finalize_api Lib "debug\bos.dll" () Declare Function pmatch Lib "debug\bos.dll" (ByVal mLength As Long, ByVal mString As Long, ByVal mPointer As Long, ByVal mPattern As Long) As Long Sub Main() Dim s As String Dim r As String s = "12345b" Dim p As String p = "$#:'b'" p = StrConv(p, vbFromUnicode) s = StrConv(s, vbFromUnicode) Dim i As Long Dim j As Long dim k as long i = Lenb(s) j = 0 initialize_api do k = pmatch(VarPtr(i), strptr(s), VarPtr(j), StrPtr(p)) 'msgbox k & " " & j if k <> 0 then exit do loop finalize_api End Sub

© Copyright Bruce M. Axtens., 2007