S>Знаю

Автор: Sheridan
Дата: 27.07.04

uses rtl/string.f

: io.r $80000000 ;
: io.w $40000000 ;

: io.create_new 1 ;
: io.create_always 2 ;
: io.open_existing 3 ;
: io.open_always 4 ;
: io.trunc_existing 5 ;

: io.pos.begin 0 ;
: io.pos.current 1 ;
: io.pos.end 2 ;

{
  KERNEL32 " CreateFileA" 7 stdcall CreateFile
  KERNEL32 " CloseHandle" 1 stdcall CloseHandle
  KERNEL32 " ReadFile" 5 stdcall ReadFile
  KERNEL32 " WriteFile" 5 stdcall WriteFile
  KERNEL32 " GetFileSize" 2 stdcall GetFileSize
  KERNEL32 " SetFilePointer" 4 stdcall SetFilePointer
  
  2 vars: access mode

  : io.open ( name access mode -- handle )
    to mode  to access
    access 0 0 mode 0 0 CreateFile
  ; {:}

  : io.close ( handle -- success )
    CloseHandle
  ; {:}

  4 vars: handle buffer size outsize

  : io.read ( handle buffer size -- written )
    to size  to buffer  to handle
    handle buffer size addr outsize 0 ReadFile drop
    outsize
  ; {:}

  : io.write ( handle buffer size -- written )
    to size  to buffer  to handle
    handle buffer size addr outsize 0 WriteFile drop
    outsize
  ; {:}

  : io.size ( handle -- size )
    0 GetFileSize
  ; {:}

  2 vars: pos mode

  : io.setpos ( handle pos mode -- pos )
    to mode  to pos  to handle
    handle pos 0 mode SetFilePointer
  ; {:}

  : io.pos ( handle -- pos )
    0 io.pos.current io.setpos
  ; {:}
}

console

uses rtl/io.f

2 vars: fwave buf

{
  var buf
  : emit ( byte -- )
    to buf
    fwave addr buf 1 io.write drop
  ; {:}

  : emit2 ( word -- )
    to buf
    fwave addr buf 2 io.write drop
  ; {:}

  : emit4 ( dword -- )
    to buf
    fwave addr buf 4 io.write drop
  ; {:}
}

: channels 2 ;
: samples/sec 44100 ;
: bits/sample 16 ;

var DataHeaderPosition

: WriteHeader
  str" RIFF" @ emit4
  0 emit4
  str" WAVE" @ emit4
  str" fmt " @ emit4
  16 emit4

  1 emit2
  channels emit2
  samples/sec emit4
  bits/sample 8 / channels * samples/sec * emit4
  bits/sample 8 / channels * emit2
  bits/sample emit2
  
  str" data" @ emit4
  0 emit4
  fwave io.pos to DataHeaderPosition
;

2 vars: DataSize FileDataSize

: CloseHeader
  fwave io.pos DataHeaderPosition - to DataSize
  fwave io.pos 8 - to FileDataSize
  fwave 4 io.pos.begin io.setpos drop
  FileDataSize emit4
  fwave DataHeaderPosition 4 - io.pos.begin io.setpos drop
  DataSize emit4
;

4 vars: ls rs bs osc

: Wave.Size [ 44100 20 * ] literal ;

: WriteWave
  Wave.Size 4 * getmem to buf
  buf to bs
  
  Wave.Size repeat
    osc $1ff * ls + to ls
    osc $4ff * rs + to rs
    osc 1+ to osc
    ls 16 >> rs $ffff0000 and or bs !
    bs 4 + to bs
  until

  fwave buf Wave.Size 4 * io.write drop
  buf freemem
;

: test
  str" 1.wav" io.w io.create_always io.open to fwave
  WriteHeader
  WriteWave
  CloseHeader
  fwave io.close drop
;

cr
." Test Wave Generator v0.0.1 by Alexey Abramov" cr
." With 32bit fixed point 44100 stereo" cr
." Play file '1.wav'" cr
test

bye

К>main(){printf("Try to simplify!");}
К>

." Try to simplify!"

F>> Большими крупными синими буквами написано

Кстати, если рассуждать о синтаксической избыточности, то зачем в
Обероне/Паскале абсолютно ненужные лексемы:

procedure
function
var
do
to, downto
...

В Modula/Oberon ни одно из указанных Вами слов не присутсвует. До Паскаля мне дела нет, он устарел давным давно.