(*~\Глагол\Приложения\Заграница\~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
                                  ОТДЕЛ editdemo;
(*
//  недоработанная трансляция с ЯП "Си"
*)
ИСПОЛЬЗУЕТ
  Strings,
  Windows;

ПОСТ
  AppName = 'EditDemo';

ВИД
  TFileName = РЯД[0..Max_Path] ИЗ ЗНАК;

ПЕР
  AMessage             :Msg;
  HWindow,HStatus,HEdit:HWnd;
  TheFont              :HFont;
  TheLogFont           :TLogFont;
  TheColor             :DWORD;
  FileName             :TFileName;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА SetStatusText(Num:ЦЕЛ; ПОСТ Text:string);
ПЕР
  StatText:РЯД[0..255] ИЗ ЗНАК;
УКАЗ
  ЕСЛИ Num = 0 ТО
    StatText[0]:=' '  (* Add space to text in first item *)
  ИНАЧЕ
    StatText[0]:=#9;  (* Center the rest *)
  КОН;
  StrPCopy(@StatText[1],Text);
  SendMessage(HStatus,SB_SETTEXT,WPARAM(Num),LPARAM(@StatText));
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА SelectFile(ПЕР FName:TFileName; Open:КЛЮЧ):КЛЮЧ;
ПОСТ
  Filter:PChar = 'Text files (*.txt)'#0'*.txt'#0+
                   'All files (*.*)'#0'*.*'#0#0;
  Ext   :PChar = 'txt';
ПЕР
  NameRec:OpenFileName;
УКАЗ
  FillChar(NameRec,SizeOf(NameRec),0);
  FName[0]:=#0;
  ДЛЯ NameRec ВЫП
    LStructSize:=SizeOf(NameRec);
    HWndOwner :=HWindow;
    LpStrFilter:=Filter;
    LpStrFile :=@FName;
    NMaxFile  :=Max_Path;
    Flags     :=OFN_Explorer ИЛИ OFN_HideReadOnly;
    ЕСЛИ Open ТО
      Flags := Flags
           ИЛИ
               OFN_FileMustExist
    КОН;
    LpStrDefExt:=Ext
  КОН;
  ЕСЛИ Open ТО
    SelectFile:=GetOpenFileName(@NameRec)
  ИНАЧЕ
    SelectFile:=GetSaveFileName(@NameRec)
  КОН
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА SaveText;
ПЕР
  Len  :ЦЕЛ;
  P    :PChar;
  F    :File;
  FName:TFileName;
УКАЗ
  ЕСЛИ SelectFile(FName,False) ТО  (*УКАЗ*)

    Assign(F,@FName);
    Rewrite(F,1);
    Len:=GetWindowTextLength(HEdit);
    GetMem(P,Len+1);
    P[Len]:=#0;

    ЕСЛИ Len>0 ТО (*УКАЗ*)
      GetWindowText(HEdit,P,Len+1);
      BlockWrite(F,P^,Len);
    КОН;

    Close(F);
    FreeMem(P,Len+1);
    StrCopy(FileName,FName);
    SetStatusText(0,StrPas(FileName));
    SetStatusText(1,'');
    SendMessage(HEdit,EM_SetModify,0,0);
  КОН;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА AskSave;
ПОСТ
  BoxType = MB_IconQuestion ИЛИ MB_YesNo;
УКАЗ
  ЕСЛИ SendMessage(HEdit,EM_GetModify,0,0)#0 ТО  (*УКАЗ*)
    ЕСЛИ MessageBox(HWindow,'Save text?','Edited',BoxType)=IdYes ТО  (*УКАЗ*)
       SaveText;
    КОН;
  КОН;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА LoadText;
ПЕР
  F    :File;
  Len  :ЦЕЛ;
  P    :PChar;
УКАЗ
  AskSave;
  ЕСЛИ SelectFile(FileName,True) ТО  (*УКАЗ*)
    Assign(F,@FileName);
    Reset(F,1);
    Len:=FileSize(F);
    GetMem(P,Len+1);
    P[Len]:=#0;
    ЕСЛИ Len>0 ТО
      BlockRead(F,P^,Len)
    КОН;
    Close(F);
    SetWindowText(HEdit,P);
    SendMessage(HEdit,EM_SetModify,0,0);
    FreeMem(P,Len+1);
    SetStatusText(0,StrPas(FileName));
    SetStatusText(1,'');
  КОН;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА NewText;
ПОСТ
  Empty:PChar = '';
УКАЗ
  AskSave;
  FileName:='Unsaved';
  SetStatusText(0,StrPas(FileName));
  SendMessage(HEdit,WM_SetText,1,LRESULT(Empty));
  SendMessage(HEdit,EM_SetModify,0,0);
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА SelectFont;
ПЕР
  ChooseFontRec:TChooseFont;
УКАЗ
  ДЛЯ ChooseFontRec ВЫП  (*УКАЗ*)
    lStructSize  :=SizeOf(ChooseFontRec);
    hwndOwner    :=HWindow;
    hDC          :=0;
    lpLogFont    :=@TheLogFont;
    iPointSize   :=0;
    Flags        :=CF_INITTOLOGFONTSTRUCT ИЛИ CF_SCREENFONTS ИЛИ CF_EFFECTS;
    rgbColors    :=TheColor;
    lCustData    :=0;
    lpfnHook     :=ПУСТО;
    lpTemplateName:=ПУСТО;
    hInstance    :=0;
    lpszStyle    :=ПУСТО;
    nFontType    :=0;
    nSizeMin     :=0;
    nSizeMax     :=0;
  КОН;
 
  ЕСЛИ ChooseFont(@ChooseFontRec) ТО  (*УКАЗ*)
    DeleteObject(TheFont);
    TheColor:=ChooseFontRec.rgbColors;
    TheFont:=CreateFontIndirect(@TheLogFont);
    SendMessage(HEdit,WM_SETFONT,WPARAM(TheFont),1);
  КОН;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА WindowProc (Window:HWnd;AMessage:UINT;WParam:WPARAM; LParam:LPARAM):LRESULT;
    stdcall; export;
ПЕР
  R       :rect;
  StatH   :LONG;
  NrMenu  :ЦЕЛ;
  NotiCode:ЦЕЛ;
УКАЗ
  WindowProc:=0;
  ВЫБРАТЬ AMessage ИЗ
    wm_Close:
      УКАЗ
        AskSave;
      КОН;
    wm_Destroy:
      УКАЗ
        PostQuitMessage (0);
        ВОЗВРАТ;
      КОН;
    wm_SetFocus:
      УКАЗ
        SetFocus(HEdit);
      КОН;
    WM_EraseBkgnd:
      УКАЗ
        ВОЗВРАТ(1);
      КОН;
    wm_Size:
      УКАЗ
        GetClientRect(HStatus,@R);
        StatH:=R.Bottom-R.Top;
        GetClientRect(Window,@R);
        MoveWindow (HEdit,0,0,R.Right,R.Bottom-StatH,False);
        MoveWindow (HStatus,0,R.Bottom-StatH,R.Right,R.Bottom,False);
      КОН;
    wm_Command:
      УКАЗ
        NotiCode:=HiWord(WParam);
        ВЫБРАТЬ NotiCode ИЗ
          en_Change    ://Editor has changed
            УКАЗ
              ЕСЛИ SendMessage(HEdit,EM_GetModify,0,0)#0 ТО
                SetStatusText(1,'Modified')
              ИНАЧЕ
                SetStatusText(1,'');
            КОН;
          ИНАЧЕ
            УКАЗ //Menu item
              NrMenu:=LoWord(WParam);
              ВЫБРАТЬ NrMenu ИЗ
                101:NewText;
                102:LoadText;
                103:SaveText;
                104:PostMessage(Window,WM_Close,0,0);
                201:SendMessage(HEdit,WM_Undo,0,0);
                202:SendMessage(HEdit,WM_Cut,0,0);
                203:SendMessage(HEdit,WM_Copy,0,0);
                204:SendMessage(HEdit,WM_Paste,0,0);
                301:SelectFont;
                401:MessageBox(Window,'Help','НЕ implemented',
                                 MB_OK ИЛИ MB_IconInformation);
              КОН;
            КОН;
        КОН;
      КОН;
    wm_CtlColorEdit:
      УКАЗ
        SetTextColor(WParam,TheColor);
        ВОЗВРАТ(GetSysColorBrush(COLOR_WINDOW));
      КОН;
  КОН;
  WindowProc:=DefWindowProc(Window,AMessage,WParam,LParam);
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА WinRegister:КЛЮЧ;
ПЕР
  WindowClass:WndClass;
УКАЗ
  ДЛЯ WindowClass ВЫП
    УКАЗ
      Style       :=cs_hRedraw ИЛИ cs_vRedraw;
      lpfnWndProc :=WndProc(@WindowProc);
      cbClsExtra  :=0;
      cbWndExtra  :=0;
      hInstance   :=system.MainInstance;
      hIcon       :=LoadIcon (0,idi_Application);
      hCursor     :=LoadCursor (0,idc_Arrow);
      hbrBackground:=GetStockObject(GRAY_BRUSH);
      lpszMenuName:=ПУСТО;
      lpszClassName:=AppName;
    КОН;
  WinRegister:=RegisterClass (WindowClass)#0;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА EditCreate(ParentWindow,Status:HWnd):HWnd;
ПОСТ
  CS_Start = WS_Child ИЛИ WS_HScroll ИЛИ WS_VScroll ИЛИ ES_MultiLine ИЛИ ES_Left;
  CS_Ex    = WS_EX_ClientEdge;
  EdiTText:PChar = '';
ПЕР
  HEdit:HWND;
  R    :TRect;
  StatH:Word;
УКАЗ
  GetClientRect(Status,@R);
  StatH:=R.Bottom-R.Top;
  GetClientRect(ParentWindow,@R);
  HEdit:=CreateWindowEx (CS_Ex,'EDIT',EditText,CS_Start,0,0,
                           R.Right-R.Left,R.Bottom-R.Top-StatH,ParentWindow,0,
                           MainInstance,ПУСТО);
  ЕСЛИ HEdit#0 ТО
    УКАЗ
      //Set Courier new as default font
      ДЛЯ TheLogFont ВЫП
        УКАЗ
          lfHeight       :=0;                // Default logical height ИЗ font
          lfWidth        :=0;                // Default logical average character width
          lfEscapement   :=0;                // angle ИЗ escapement
          lfOrientation  :=0;                // base-line orientation angle
          lfWeight       :=FW_NORMAL;        // font weight
          lfItalic       :=0;                // italic attribute flag
          lfUnderline    :=0;                // underline attribute flag
          lfStrikeOut    :=0;                // strikeout attribute flag
          lfCharSet      :=DEFAULT_CHARSET;  // character set identifier
          lfOutPrecision :=OUT_DEFAULT_PRECIS;  // output precision
          lfClipPrecision:=CLIP_DEFAULT_PRECIS; // clipping precision
          lfQuality      :=DEFAULT_QUALITY;     // output quality
          lfPitchAndFamily:=DEFAULT_PITCH;    // pitch И family
          Strcopy(lfFaceName,'Courier New');    // pointer to typeface name string
        КОН;
      TheColor:=GetSysColor(COLOR_WINDOWTEXT);
      TheFont:=CreateFontIndirect(@TheLogFont);
      SendMessage(HEdit,WM_SETFONT,WPARAM(TheFont),1);
      ShowWindow(Hedit,SW_Show);
      UpdateWindow(HEdit);
    КОН;
  EditCreate:=HEdit;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА WinCreate:HWnd;

ПЕР hWindow:HWnd;
    Menu   :hMenu;
    SubMenu:hMenu;
УКАЗ
  hWindow:=CreateWindow (AppName,'EditDemo',ws_OverlappedWindow,
                           cw_UseDefault,cw_UseDefault,cw_UseDefault,
                           cw_UseDefault,0,0,MainInstance,ПУСТО);
  ЕСЛИ hWindow#0 ТО
    УКАЗ
      Menu:=CreateMenu;
      SubMenu:=CreateMenu;
      AppendMenu(Submenu,MF_STRING,101,'&New...');
      AppendMenu(Submenu,MF_STRING,102,'&Open...');
      AppendMenu(Submenu,MF_STRING,103,'&Save...');
      AppendMenu(Submenu,MF_SEPARATOR,0,ПУСТО);
      AppendMenu(SubMenu,MF_String,104,'E&xit');
      AppendMenu(Menu,MF_POPUP,SubMenu,'&File');
      SubMenu:=CreateMenu;
      AppendMenu(SubMenu,MF_String,201,'&Undo'#8'Ctrl+Z');
      AppendMenu(Submenu,MF_SEPARATOR,0,ПУСТО);
      AppendMenu(SubMenu,MF_String,202,'&Cut'#8'Ctrl+X');
      AppendMenu(SubMenu,MF_String,203,'&Copy'#8'Ctrl+C');
      AppendMenu(SubMenu,MF_STRING,204,'&Paste'#8'Ctrl+V');
      AppendMenu(Menu,MF_POPUP,SubMenu,'&Edit');
      SubMenu:=CreateMenu;
      AppendMenu(SubMenu,MF_String,301,'&Font...');
      AppendMenu(Menu,MF_POPUP,SubMenu,'&Options');
      AppendMenu(Menu,MF_STRING,401,'&Help');
      SetMenu(hWindow,menu);
      ShowWindow(hWindow,SW_Show);
      UpdateWindow(hWindow);
    КОН;
  WinCreate:=hWindow;
КОН;

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
ЗАДАЧА StatusCreate (parent:hwnd):HWnd;
ПЕР
  AWnd  :HWnd;
  Edges :РЯД[1..2] ИЗ ЦЕЛ;
УКАЗ
  FileName:='Unsaved';
  AWnd:=CreateStatusWindow(WS_CHILD ИЛИ WS_VISIBLE,FileName,Parent,$7712);
  // Create items:
  ЕСЛИ AWnd # 0 ТО
    УКАЗ
      Edges[1]:=400;
      Edges[2]:=500;
      SendMessage(AWnd,SB_SETPARTS,2,LPARAM(@Edges));
    КОН;
  StatusCreate:=AWnd;
КОН;

(*-SSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSS-*)
УКАЗ
  ЕСЛИ
       НЕ WinRegister
  ТО
         MessageBox(0,'Register failed',ПУСТО,mb_Ok);
  ИНАЧЕ
    hWindow:=WinCreate;
    ЕСЛИ ЦЕЛ(hWindow)=0 ТО
         MessageBox(0,'WinCreate failed',ПУСТО,MB_OK);
    ИНАЧЕ
      HStatus:=statuscreate(hwindow);
      HEdit:=EditCreate(HWindow,HStatus);
      SetFocus(HEdit);
      ПОКА GetMessage(@AMessage,0,0,0) ВЫП
        TranslateMessage(AMessage);
        DispatchMessage(AMessage);
      КОН;
      DeleteObject(TheFont);
      СТОП(AMessage.wParam);
    КОН;
  КОН;
КОН editdemo.
